;; Copyright (C) 2002 Daiki Ueno
;; Author: Daiki Ueno <ueno@unixuser.org>
-;; Keywords: adress book
+;; Keywords: address book
;; This file is part of the Lovely Sister Database.
;;; (define-key gnus-summary-mode-map ":" 'lsdb-toggle-buffer)))
;;; For Wanderlust, put the following lines into your ~/.wl:
-;;; (require 'lsdb)
-;;; (lsdb-wl-insinuate)
+;;; (autoload 'lsdb-wl-insinuate "lsdb")
+;;; (add-hook 'wl-init-hook 'lsdb-wl-insinuate)
;;; (add-hook 'wl-draft-mode-hook
;;; (lambda ()
;;; (define-key wl-draft-mode-map "\M-\t" 'lsdb-complete-name)))
;;; (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)))
+;;; (define-key mew-summary-mode-map "L" 'lsdb-toggle-buffer)))
;;; Code:
:type 'list)
(defcustom lsdb-interesting-header-alist
- '(("Organization" nil organization)
+ `(("Organization" nil organization)
("\\(X-\\)?User-Agent\\|X-Mailer\\|X-Newsreader" nil user-agent)
("\\(X-\\)?ML-Name" nil mailing-list)
("List-Id" "\\(.*\\)[ \t]+<[^>]+>\\'" mailing-list "\\1")
("Delivered-To" "mailing list[ \t]+\\([^@]+\\)@.*" mailing-list "\\1")
("\\(X-URL\\|X-URI\\)" nil www)
("X-Attribution\\|X-cite-me" nil attribution)
- ("X-Face" nil x-face))
+ ("X-Face" nil x-face)
+ ("Face" nil face)
+ (,lsdb-sender-headers nil sender))
"Alist of headers we are interested in.
The format of elements of this list should be
(FIELD-NAME REGEXP ENTRY STRING)
(www 4)
(aka 4 ?,)
(score -1)
- (x-face -1))
+ (x-face -1)
+ (face -1)
+ (sender -1))
"Alist of entry types for presentation.
The format of elements of this list should be
(ENTRY SCORE [CLASS READ-ONLY])
:group 'lsdb
:type 'hook)
-(defcustom lsdb-update-record-functions
+(defcustom lsdb-after-update-record-functions
'(lsdb-update-address-cache)
"List of functions called after a record is updated.
The updated record is passed to each function as the argument."
:group 'lsdb
:type 'hook)
+(defcustom lsdb-after-delete-record-functions
+ '(lsdb-delete-address-cache)
+ "List of functions called after a record is removed.
+The removed record is passed to each function as the argument."
+ :group 'lsdb
+ :type 'hook)
+
(defcustom lsdb-secondary-hash-tables
'(lsdb-address-cache)
"List of the hash tables for reverse lookup"
:group 'lsdb
:type 'symbol)
+(defcustom lsdb-x-face-scale-factor 0.5
+ "A number used to scale down or scale up X-Face images."
+ :group 'lsdb
+ :type 'number)
+
(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"))
+ '((pbm "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pnmscale " scale-factor)
+ (xpm "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | pnmscale " scale-factor " | ppmtoxpm"))
"An alist from an image type to a command to be executed to display an X-Face header.
The command will be executed in a sub-shell asynchronously.
The compressed face will be piped to this command."
:group 'lsdb
:type 'function)
-(defcustom lsdb-print-record-hook '(lsdb-expose-x-face)
+(defcustom lsdb-face-image-type nil
+ "A image type of displayed face.
+If non-nil, supersedes the return value of `lsdb-x-face-available-image-type'."
+ :group 'lsdb
+ :type 'symbol)
+
+(defcustom lsdb-face-scale-factor 0.5
+ "A number used to scale down or scale up Face images."
+ :group 'lsdb
+ :type 'number)
+
+(defcustom lsdb-face-command-alist
+ '((png "pngtopnm | pnmscale " scale-factor " | pnmtopng")
+ (xpm "pngtopnm | pnmscale " scale-factor " | ppmtoxpm"))
+ "An alist from an image type to a command to be executed to display a Face header.
+The command will be executed in a sub-shell asynchronously.
+The decoded field-body (actually a PNG data) will be piped to this command."
+ :group 'lsdb
+ :type 'list)
+
+(defcustom lsdb-insert-face-function
+ (if (static-if (featurep 'xemacs)
+ (or (featurep 'png)
+ (featurep 'xpm))
+ (and (>= emacs-major-version 21)
+ (fboundp 'image-type-available-p)
+ (or (image-type-available-p 'png)
+ (image-type-available-p 'xpm))))
+ #'lsdb-insert-face-asynchronously)
+ "Function to display Face."
+ :group 'lsdb
+ :type 'function)
+
+(defcustom lsdb-print-record-hook '(lsdb-expose-x-face lsdb-expose-face)
"A hook called after a record is displayed."
:group 'lsdb
:type 'hook)
:group 'lsdb
:type 'function)
+(defcustom lsdb-display-records-belong-to-user t
+ "Non-nil means LSDB displays records belong to yourself.
+When this option is equal to nil and a message is sent by the user
+whose address is `user-mail-address', the LSDB record for the To: line
+will be shown instead of the one for the From: line."
+ :group 'lsdb
+ :type 'boolean)
+
(defcustom lsdb-pop-up-windows t
"Non-nil means LSDB should make new windows to display records."
:group 'lsdb
:type 'boolean
:group 'lsdb)
+(defcustom lsdb-strip-address nil
+ "If non-nil, strip display-name from sender address before completion."
+ :group 'lsdb
+ :type 'boolean)
+
+(defcustom lsdb-use-migemo nil
+ "If non-nil, use `migemo' when complete address."
+ :type 'boolean
+ :group 'lsdb)
+
;;;_. Faces
(defface lsdb-header-face
'((t (:underline t)))
The function is called with one argument, the buffer to be displayed.
Overrides `temp-buffer-show-function'.")
+;;;_. Utility functions
+(defun lsdb-substitute-variables (program variable value)
+ (setq program (copy-sequence program))
+ (let ((pointer program))
+ (while pointer
+ (setq pointer (memq variable program))
+ (if pointer
+ (setcar pointer value)))
+ program))
+
;;;_. Hash Table Emulation
(if (and (fboundp 'make-hash-table)
(subrp (symbol-function 'make-hash-table)))
(save-excursion
(goto-char marker)
(if (looking-at "^#s(")
- (with-temp-buffer
- (buffer-disable-undo)
- (insert-buffer-substring (marker-buffer marker) marker)
- (goto-char (point-min))
- (delete-char 2)
- (let ((object (read (current-buffer)))
- hash-table data)
- (if (eq 'hash-table (car object))
- (progn
- (setq hash-table
- (lsdb-make-hash-table
- :size (plist-get (cdr object) 'size)
- :test 'equal)
- data (plist-get (cdr object) 'data))
- (while data
- (lsdb-puthash (pop data) (pop data) hash-table))
- hash-table)
- object)))))))))
+ (let ((end-marker
+ (progn
+ (forward-char 2) ;skip "#s"
+ (forward-sexp) ;move to the left paren
+ (point-marker))))
+ (with-temp-buffer
+ (buffer-disable-undo)
+ (insert-buffer-substring (marker-buffer marker)
+ marker end-marker)
+ (goto-char (point-min))
+ (delete-char 2)
+ (let ((object (read (current-buffer)))
+ hash-table data)
+ (if (eq 'hash-table (car object))
+ (progn
+ (setq hash-table
+ (lsdb-make-hash-table
+ :size (plist-get (cdr object) 'size)
+ :test 'equal)
+ data (plist-get (cdr object) 'data))
+ (while data
+ (lsdb-puthash (pop data) (pop data) hash-table))
+ hash-table)
+ object))))
+ (read marker)))))))
(defun lsdb-load-hash-tables ()
"Read the contents of `lsdb-file' into the internal hash tables."
;; XEmacs doesn't have a distinction between index-size and
;; hash-table-size.
(number-to-string (lsdb-hash-table-count hash-table))
- " test equal data (")
+ " test equal data (\n")
(lsdb-maphash
(lambda (key value)
(let (print-level print-length)
- (insert (prin1-to-string key) " " (prin1-to-string value) " ")))
+ (insert (prin1-to-string key) " " (prin1-to-string value) "\n")))
hash-table)
(insert "))"))
(symbol-name (coding-system-name
lsdb-file-coding-system))))))
(if coding-system-name
- (insert ";;; -*- coding: " coding-system-name " -*-\n"))))
+ (insert ";;; -*- mode: emacs-lisp; coding: "
+ coding-system-name " -*-\n"))))
(lsdb-insert-hash-table lsdb-hash-table)
;; Save the secondary hash tables following.
(setq tables lsdb-secondary-hash-tables)
(setq tables (cdr tables))))))
;;;_. Mail Header Extraction
-(defun lsdb-fetch-field-bodies (regexp)
+(defun lsdb-fetch-fields (regexp)
(save-excursion
(goto-char (point-min))
(let ((case-fold-search t)
field-bodies)
(while (re-search-forward (concat "^\\(" regexp "\\):[ \t]*")
nil t)
- (push (funcall lsdb-decode-field-body-function
- (buffer-substring (point) (std11-field-end))
- (match-string 1))
- field-bodies))
+ (push (cons (match-string 1)
+ (buffer-substring (point) (std11-field-end)))
+ field-bodies))
(nreverse field-bodies))))
(defun lsdb-canonicalize-spaces-and-dots (string)
(while tables
(when (or force (not (symbol-value (car tables))))
(set (car tables) (lsdb-make-hash-table :test 'equal))
- (lsdb-maphash
- (lambda (key value)
- (run-hook-with-args
- 'lsdb-update-record-functions
- (cons key value)))
- lsdb-hash-table)
(setq lsdb-hash-tables-are-dirty t))
- (setq tables (cdr tables)))))
+ (setq tables (cdr tables))))
+ (if lsdb-hash-tables-are-dirty
+ (lsdb-maphash
+ (lambda (key value)
+ (run-hook-with-args
+ 'lsdb-after-update-record-functions
+ (cons key value)))
+ lsdb-hash-table)))
(defun lsdb-maybe-load-hash-tables ()
(unless lsdb-hash-table
(while net
(lsdb-puthash (pop net) (car record) lsdb-address-cache))))
+(defun lsdb-delete-address-cache (record)
+ (let ((net (cdr (assq 'net record))))
+ (while net
+ (lsdb-remhash (pop net) lsdb-address-cache))))
+
;;;_ , #2 Iterate on the All Records (very slow)
(defun lsdb-lookup-full-name-by-fuzzy-matching (sender)
(let ((names
;;;_ : Update Records
(defun lsdb-update-record (sender &optional interesting)
(let ((old (lsdb-gethash (car sender) lsdb-hash-table))
- (new (cons (cons 'net (list (nth 1 sender)))
- interesting))
+ (new (if (nth 1 sender)
+ (cons (cons 'net (list (nth 1 sender)))
+ interesting)
+ interesting))
merged
record
full-name)
(cdr record)))))
(lsdb-puthash (car record) (cdr record)
lsdb-hash-table)
- (run-hook-with-args 'lsdb-update-record-functions record)
+ (run-hook-with-args 'lsdb-after-update-record-functions record)
(setq lsdb-hash-tables-are-dirty t))
record))
(save-restriction
(std11-narrow-to-header)
(setq senders
- (delq nil (mapcar #'lsdb-extract-address-components
- (lsdb-fetch-field-bodies
+ (delq nil (mapcar (lambda (field)
+ (let ((components
+ (lsdb-extract-address-components
+ (cdr field))))
+ (if components
+ (setcar
+ components
+ (funcall lsdb-decode-field-body-function
+ (car components) (car field))))
+ components))
+ (lsdb-fetch-fields
lsdb-sender-headers)))
recipients
- (delq nil (mapcar #'lsdb-extract-address-components
- (lsdb-fetch-field-bodies
+ (delq nil (mapcar (lambda (field)
+ (let ((components
+ (lsdb-extract-address-components
+ (cdr field))))
+ (if components
+ (setcar
+ components
+ (funcall lsdb-decode-field-body-function
+ (car components) (car field))))
+ components))
+ (lsdb-fetch-fields
lsdb-recipients-headers))))
(setq alist lsdb-interesting-header-alist)
(while alist
(setq bodies
(delq nil (mapcar
- (lambda (field-body)
- (if (nth 1 (car alist))
- (and (string-match (nth 1 (car alist))
- field-body)
- (replace-match (nth 3 (car alist))
- nil nil field-body))
- field-body))
- (lsdb-fetch-field-bodies (car (car alist))))))
+ (lambda (field)
+ (let ((field-body
+ (funcall lsdb-decode-field-body-function
+ (cdr field) (car field))))
+ (if (nth 1 (car alist))
+ (and (string-match (nth 1 (car alist))
+ field-body)
+ (replace-match (nth 3 (car alist))
+ nil nil field-body))
+ field-body)))
+ (lsdb-fetch-fields (car (car alist))))))
(when bodies
(setq entry (or (nth 2 (car alist))
'notes))
(set-window-buffer window buffer)
(lsdb-fit-window-to-buffer window)))))
+(defun lsdb-update-records-and-display ()
+ (let ((records (lsdb-update-records)))
+ (if lsdb-display-records-belong-to-user
+ (if records
+ (lsdb-display-record (car records))
+ (lsdb-hide-buffer))
+ (catch 'lsdb-show-record
+ (while records
+ (if (member user-mail-address (cdr (assq 'net (car records))))
+ (setq records (cdr records))
+ (lsdb-display-record (car records))
+ (throw 'lsdb-show-record t)))
+ (lsdb-hide-buffer)))))
+
(defun lsdb-display-record (record)
"Display only one RECORD, then shrink the window as possible."
(let ((temp-buffer-show-function lsdb-temp-buffer-show-function))
(lsdb-display-records (list record))))
(defun lsdb-display-records (records)
- (with-output-to-temp-buffer lsdb-buffer-name
- (set-buffer standard-output)
- (setq records
- (sort (copy-sequence records)
- (or lsdb-display-records-sort-predicate
- (lambda (record1 record2)
- (string-lessp (car record1) (car record2))))))
- (while records
- (save-restriction
- (narrow-to-region (point) (point))
- (lsdb-print-record (car records)))
- (goto-char (point-max))
- (setq records (cdr records)))
- (lsdb-mode)))
+ (with-current-buffer (get-buffer-create lsdb-buffer-name)
+ (let ((standard-output (current-buffer))
+ (inhibit-read-only t)
+ buffer-read-only)
+ (buffer-disable-undo)
+ (erase-buffer)
+ (setq records
+ (sort (copy-sequence records)
+ (or lsdb-display-records-sort-predicate
+ (lambda (record1 record2)
+ (string-lessp (car record1) (car record2))))))
+ (while records
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (lsdb-print-record (car records)))
+ (goto-char (point-max))
+ (setq records (cdr records))))
+ (lsdb-mode)
+ (set-buffer-modified-p lsdb-hash-tables-are-dirty)
+ (goto-char (point-min))
+ (if temp-buffer-show-function
+ (funcall temp-buffer-show-function (current-buffer))
+ (pop-to-buffer (current-buffer)))))
(defsubst lsdb-entry-score (entry)
(or (nth 1 (assq (car entry) lsdb-entry-type-alist)) 0))
;;;_ : Matching Highlight
(defvar lsdb-last-highlight-overlay nil)
+;;; avoid byte-compile warning for migemo
+(eval-when-compile
+ (autoload 'migemo-get-pattern "migemo"))
+
(defun lsdb-complete-name-highlight (start end)
(make-local-hook 'pre-command-hook)
(add-hook 'pre-command-hook 'lsdb-complete-name-highlight-update nil t)
(save-excursion
(goto-char start)
- (search-forward lsdb-last-completion end)
+ (if (and lsdb-use-migemo (fboundp 'migemo-get-pattern))
+ (re-search-forward lsdb-last-completion end)
+ (search-forward lsdb-last-completion end))
(setq lsdb-last-highlight-overlay
(make-overlay (match-beginning 0) (match-end 0)))
(overlay-put lsdb-last-highlight-overlay 'face
(unless (eq last-command this-command)
(setq lsdb-last-candidates nil
lsdb-last-candidates-pointer nil
- lsdb-last-completion (buffer-substring start (point))
- pattern (concat "\\<" (regexp-quote lsdb-last-completion)))
+ lsdb-last-completion (buffer-substring start (point)))
+ (if (and lsdb-use-migemo (fboundp 'migemo-get-pattern))
+ (setq lsdb-last-completion (migemo-get-pattern lsdb-last-completion)
+ pattern (concat "\\<\\(" lsdb-last-completion "\\)"))
+ (setq pattern (concat "\\<" (regexp-quote lsdb-last-completion))))
(lsdb-maphash
(lambda (key value)
- (let ((net (cdr (assq 'net value))))
- (if (string-match pattern key)
- (setq lsdb-last-candidates
- (nconc lsdb-last-candidates
- (mapcar (lambda (address)
- (if (equal key address)
- key
- (concat key " <" address ">")))
- net)))
- (while net
- (if (string-match pattern (car net))
- (push (car net) lsdb-last-candidates))
- (setq net (cdr net))))))
+ (setq lsdb-last-candidates
+ (nconc lsdb-last-candidates
+ (delq nil (mapcar
+ (lambda (candidate)
+ (if (string-match pattern candidate)
+ candidate))
+ (if lsdb-strip-address
+ (cdr (assq 'net value))
+ (append (cdr (assq 'net value))
+ (cdr (assq 'sender value)))))))))
lsdb-hash-table)
;; Sort candidates by the position where the pattern occurred.
(setq lsdb-last-candidates
(let ((keymap (make-sparse-keymap)))
(define-key keymap "a" 'lsdb-mode-add-entry)
(define-key keymap "d" 'lsdb-mode-delete-entry)
+ (define-key keymap "D" 'lsdb-mode-delete-record)
(define-key keymap "e" 'lsdb-mode-edit-entry)
+ (define-key keymap "E" 'lsdb-mode-edit-record)
(define-key keymap "l" 'lsdb-mode-load)
(define-key keymap "s" 'lsdb-mode-save)
(define-key keymap "q" 'lsdb-mode-quit-window)
"Return the current record name."
(get-text-property (point) 'lsdb-record))
+(defun lsdb-delete-record (record)
+ "Delete given RECORD."
+ (lsdb-remhash (car record) lsdb-hash-table)
+ (run-hook-with-args 'lsdb-after-delete-record-functions record)
+ (setq lsdb-hash-tables-are-dirty t))
+
(defun lsdb-current-entry ()
"Return the current entry name in canonical form."
(save-excursion
(setcdr record (delq entry (cdr record)))
(lsdb-puthash (car record) (cdr record)
lsdb-hash-table)
- (run-hook-with-args 'lsdb-update-record-functions record)
+ (run-hook-with-args 'lsdb-after-update-record-functions record)
(setq lsdb-hash-tables-are-dirty t))
(defun lsdb-mode-add-entry (entry-name)
(setcdr record (cons (cons ',entry-name form) (cdr record)))
(lsdb-puthash (car record) (cdr record)
lsdb-hash-table)
- (run-hook-with-args 'lsdb-update-record-functions record)
+ (run-hook-with-args 'lsdb-after-update-record-functions record)
(setq lsdb-hash-tables-are-dirty t)
(beginning-of-line 2)
(add-text-properties
(lsdb-read-entry record "Which entry to delete: "))
entry (assq entry-name (cdr record)))
(when (and entry
- (or (not (interactive-p))
- (not lsdb-verbose)
+ (or (not lsdb-verbose)
(y-or-n-p
- (format "Do you really want to delete entry `%s' of `%s'?"
+ (format "Do you really want to delete entry `%s' of `%s'? "
entry-name (car record)))))
(lsdb-delete-entry record entry)
(lsdb-mode-delete-entry-1 entry))))
+(defun lsdb-mode-delete-record ()
+ "Delete the record on the current line."
+ (interactive)
+ (let ((record (lsdb-current-record)))
+ (unless record
+ (error "%s" "There is nothing to follow here"))
+ (when (or (not lsdb-verbose)
+ (yes-or-no-p
+ (format "Do you really want to delete entire record of `%s'? "
+ (car record))))
+ (lsdb-delete-record record)
+ (save-restriction
+ (lsdb-narrow-to-record)
+ (let ((inhibit-read-only t)
+ buffer-read-only)
+ (delete-region (point-min) (point-max)))))))
+
+(defun lsdb-mode-delete-entry-or-record ()
+ "Delete the entry on the current line.
+If the cursor is on the first line of a database entry (the name line)
+then the entire entry will be deleted."
+ (interactive)
+ (if (lsdb-current-entry)
+ (lsdb-mode-delete-entry)
+ (lsdb-mode-delete-record)))
+
(defun lsdb-mode-edit-entry ()
"Edit the entry on the current line."
(interactive)
- (let ((record (lsdb-current-record))
- entry-name entry marker)
+ (let ((record (lsdb-current-record)))
(unless record
(error "There is nothing to follow here"))
- (setq entry-name (or (lsdb-current-entry)
- (lsdb-read-entry record "Which entry to edit: "))
- entry (assq entry-name (cdr record))
- marker (point-marker))
- (lsdb-edit-form
- (cdr entry) "Editing the entry."
- `(lambda (form)
- (unless (equal form ',(cdr entry))
- (save-excursion
- (set-buffer lsdb-buffer-name)
- (goto-char ,marker)
- (let ((record (lsdb-current-record))
- entry
- (inhibit-read-only t)
- buffer-read-only)
- (unless record
- (error "The entry currently in editing is discarded"))
- (setq entry (assq ',entry-name (cdr record)))
+ (let ((entry-name (or (lsdb-current-entry)
+ (lsdb-read-entry record "Which entry to edit: "))))
+ (lsdb-edit-form
+ (cdr (assq entry-name (cdr record))) "Editing the entry."
+ `(lambda (form)
+ (let* ((record ',record)
+ (entry-name ',entry-name)
+ (entry (assq entry-name (cdr record))))
+ (unless (equal form (cdr entry))
(setcdr entry form)
- (run-hook-with-args 'lsdb-update-record-functions record)
+ (run-hook-with-args 'lsdb-after-update-record-functions record)
(setq lsdb-hash-tables-are-dirty t)
- (lsdb-mode-delete-entry-1 entry)
- (beginning-of-line)
- (add-text-properties
- (point)
- (progn
- (lsdb-insert-entry (cons ',entry-name form))
- (point))
- (list 'lsdb-record record)))))))))
+ (with-current-buffer lsdb-buffer-name
+ (let ((inhibit-read-only t)
+ buffer-read-only
+ (pos (text-property-any (point-min) (point-max)
+ 'lsdb-record record)))
+ (unless pos
+ (error "%s" "The entry currently in editing is discarded"))
+ (lsdb-mode-delete-entry-1 entry)
+ (forward-line 0)
+ (add-text-properties
+ (point)
+ (progn
+ (lsdb-insert-entry (cons entry-name form))
+ (point))
+ (list 'lsdb-record record)))))))))))
+
+(defun lsdb-mode-edit-record ()
+ "Edit the name of the record on the current line."
+ (interactive)
+ (let ((record (lsdb-current-record)))
+ (unless record
+ (error "There is nothing to follow here"))
+ (lsdb-edit-form
+ (car record) "Editing the name."
+ `(lambda (new-name)
+ (unless (stringp new-name)
+ (error "String is required: `%s'" new-name))
+ (let* ((record ',record)
+ (old-name (car record)))
+ (unless (equal new-name old-name)
+ (lsdb-delete-record record)
+ (setcar record new-name)
+ (lsdb-puthash new-name (cdr record) lsdb-hash-table)
+ (run-hook-with-args 'lsdb-after-update-record-functions record)
+ (setq lsdb-hash-tables-are-dirty t)
+ (with-current-buffer lsdb-buffer-name
+ (let ((inhibit-read-only t)
+ buffer-read-only
+ (pos (text-property-any (point-min) (point-max)
+ 'lsdb-record record)))
+ (unless pos
+ (error "%s" "The entry currently in editing is discarded"))
+ (delete-region (point) (+ (point) (length old-name)))
+ (add-text-properties (point)
+ (progn (insert form) (point))
+ (list 'lsdb-record record))))))))))
+
+(defun lsdb-mode-edit-entry-or-record ()
+ "Edit the entry on the current line.
+If the cursor is on the first line of a database entry (the name line)
+then the name of this record will be edited."
+ (interactive)
+ (if (lsdb-current-entry)
+ (lsdb-mode-edit-entry)
+ (lsdb-mode-edit-record)))
-(defun lsdb-mode-save (&optional dont-ask)
+(defun lsdb-mode-save (&optional force)
"Save LSDB hash table into `lsdb-file'."
- (interactive)
- (if (not lsdb-hash-tables-are-dirty)
+ (interactive "P")
+ (if (not (or force
+ lsdb-hash-tables-are-dirty))
(message "(No changes need to be saved)")
- (when (or (interactive-p)
- dont-ask
+ (when (or (interactive-p) ;Don't ask user if this
+ ;function is called as a
+ ;command.
(not lsdb-verbose)
(y-or-n-p "Save the LSDB now? "))
(lsdb-save-hash-tables)
- (setq lsdb-hash-tables-are-dirty nil)
+ (set-buffer-modified-p (setq lsdb-hash-tables-are-dirty nil))
(message "The LSDB was saved successfully."))))
(defun lsdb-mode-load ()
(add-hook 'gnus-article-prepare-hook 'lsdb-gnus-update-record)
(add-hook 'gnus-save-newsrc-hook 'lsdb-mode-save))
-(defvar gnus-current-headers)
+(defvar gnus-article-current-summary)
+(defvar gnus-original-article-buffer)
(defun lsdb-gnus-update-record ()
- (let ((entity gnus-current-headers)
- records)
- (with-temp-buffer
- (set-buffer-multibyte nil)
- (buffer-disable-undo)
- (mime-insert-entity entity)
- (setq records (lsdb-update-records))
- (when records
- (lsdb-display-record (car records))))))
+ (with-current-buffer (with-current-buffer gnus-article-current-summary
+ gnus-original-article-buffer)
+ (lsdb-update-records-and-display)))
;;;_. Interface to Wanderlust
;;;###autoload
(defun lsdb-wl-update-record ()
(save-excursion
(set-buffer (wl-message-get-original-buffer))
- (let ((records (lsdb-update-records)))
- (when records
- (let ((lsdb-temp-buffer-show-function
- #'lsdb-wl-temp-buffer-show-function))
- (lsdb-display-record (car records)))))))
+ (let ((lsdb-temp-buffer-show-function
+ #'lsdb-wl-temp-buffer-show-function))
+ (lsdb-update-records-and-display))))
(defun lsdb-wl-toggle-buffer (&optional arg)
"Toggle hiding of the LSDB window for Wanderlust.
;;;_. Interface to Mew written by Hideyuki SHIRAI <shirai@meadowy.org>
(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-xinfo-get-decode-err "mew")
- (autoload 'mew-xinfo-get-action "mew"))
+ (condition-case nil
+ (progn
+ (require 'mew)
+ ;; Avoid macro `mew-cache-hit' expand (Mew 1.94.2 or earlier).
+ ;; Changed `mew-cache-hit' from macro to function at Mew 2.0.
+ (if (not (fboundp 'mew-current-get-fld))
+ (setq byte-compile-macro-environment
+ (cons '(mew-cache-hit . nil)
+ byte-compile-macro-environment))))
+ (error
+ ;; Silence byte compiler for environments where Mew does not installed.
+ (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-xinfo-get-decode-err "mew")
+ (autoload 'mew-xinfo-get-action "mew"))))
;;;###autoload
(defun lsdb-mew-insinuate ()
(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))
- records)
+ (cache (mew-cache-hit fld msg)))
(when cache
(save-excursion
(set-buffer cache)
(lambda (body name)
(set-text-properties 0 (length body) nil body)
body))
- (when (setq records (lsdb-update-records))
- (lsdb-display-record (car records))))))))
+ (lsdb-update-records-and-display))))))
;;;_. Interface to MU-CITE
(eval-when-compile
(cdr (car records))))
(lsdb-puthash (car (car records)) (cdr (car records))
lsdb-hash-table)
- (run-hook-with-args 'lsdb-update-record-functions (car records))
+ (run-hook-with-args 'lsdb-after-update-record-functions (car records))
(setq lsdb-hash-tables-are-dirty t)))))
(defun lsdb-mu-get-prefix-method ()
(lsdb-x-face-available-image-type)))
(shell-file-name lsdb-shell-file-name)
(shell-command-switch lsdb-shell-command-switch)
+ (coding-system-for-read 'binary)
(process-connection-type nil)
(cached (cdr (assq type (lsdb-gethash x-face lsdb-x-face-cache))))
(marker (point-marker))
+ buffer
process)
(if cached
(lsdb-insert-x-face-image cached type marker)
+ (with-current-buffer (setq buffer (generate-new-buffer " *lsdb work*"))
+ (buffer-disable-undo)
+ (set-buffer-multibyte nil))
(setq process
(start-process-shell-command
- "lsdb-x-face-command" (generate-new-buffer " *lsdb work*")
+ "lsdb-x-face-command" buffer
(concat "{ "
- (nth 1 (assq type lsdb-x-face-command-alist))
+ (apply #'concat
+ (lsdb-substitute-variables
+ (cdr (assq type lsdb-x-face-command-alist))
+ 'scale-factor
+ (number-to-string lsdb-x-face-scale-factor)))
"; } 2> /dev/null")))
+ (set-process-filter
+ process
+ `(lambda (process string)
+ (save-excursion
+ (set-buffer ,buffer)
+ (goto-char (point-max))
+ (insert string))))
+ (set-process-sentinel
+ process
+ `(lambda (process string)
+ (unwind-protect
+ (if (equal string "finished\n")
+ (let ((data
+ (with-current-buffer ,buffer
+ (buffer-string))))
+ (lsdb-insert-x-face-image data ',type ,marker)
+ (lsdb-puthash ,x-face (list (cons ',type data))
+ lsdb-x-face-cache)))
+ (kill-buffer ,buffer))))
(process-send-string process (concat x-face "\n"))
- (process-send-eof process)
+ (process-send-eof process))))
+
+;;;_. Face Rendering
+(defvar lsdb-face-cache
+ (lsdb-make-hash-table :test 'equal))
+
+(defun lsdb-face-available-image-type ()
+ (static-if (featurep 'xemacs)
+ (if (featurep 'png)
+ 'png
+ (if (featurep 'xpm)
+ 'xpm))
+ (and (>= emacs-major-version 21)
+ (fboundp 'image-type-available-p)
+ (if (image-type-available-p 'png)
+ 'png
+ (if (image-type-available-p 'xpm)
+ 'xpm)))))
+
+(defun lsdb-expose-face ()
+ (let* ((record (get-text-property (point-min) 'lsdb-record))
+ (face (cdr (assq 'face (cdr record))))
+ (delimiter "\r "))
+ (when (and lsdb-insert-face-function
+ face)
+ (goto-char (point-min))
+ (end-of-line)
+ (put-text-property 0 1 'invisible t delimiter) ;hide "\r"
+ (put-text-property
+ (point)
+ (progn
+ (insert delimiter)
+ (while face
+ (funcall lsdb-insert-face-function (pop face)))
+ (point))
+ 'lsdb-record record))))
+
+(defun lsdb-insert-face-image (data type marker)
+ (static-if (featurep 'xemacs)
+ (save-excursion
+ (set-buffer (marker-buffer marker))
+ (goto-char marker)
+ (let* ((inhibit-read-only t)
+ buffer-read-only
+ (glyph (make-glyph (vector type :data data))))
+ (set-extent-begin-glyph
+ (make-extent (point) (point))
+ glyph)))
+ (save-excursion
+ (set-buffer (marker-buffer marker))
+ (goto-char marker)
+ (let* ((inhibit-read-only t)
+ buffer-read-only
+ (image (create-image data type t :ascent 'center))
+ (record (get-text-property (point) 'lsdb-record)))
+ (put-text-property (point) (progn
+ (insert-image image)
+ (point))
+ 'lsdb-record record)))))
+
+(defun lsdb-insert-face-asynchronously (face)
+ (let* ((type (or lsdb-face-image-type
+ (lsdb-face-available-image-type)))
+ (shell-file-name lsdb-shell-file-name)
+ (shell-command-switch lsdb-shell-command-switch)
+ (coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (process-connection-type nil)
+ (cached (cdr (assq type (lsdb-gethash face lsdb-face-cache))))
+ (marker (point-marker))
+ buffer
+ process)
+ (if cached
+ (lsdb-insert-face-image cached type marker)
+ (with-current-buffer (setq buffer (generate-new-buffer " *lsdb work*"))
+ (buffer-disable-undo)
+ (set-buffer-multibyte nil))
+ (setq process
+ (start-process-shell-command
+ "lsdb-face-command" buffer
+ (concat "{ "
+ (apply #'concat
+ (lsdb-substitute-variables
+ (cdr (assq type lsdb-face-command-alist))
+ 'scale-factor
+ (number-to-string lsdb-face-scale-factor)))
+ "; } 2> /dev/null")))
+ (set-process-filter
+ process
+ `(lambda (process string)
+ (save-excursion
+ (set-buffer ,buffer)
+ (goto-char (point-max))
+ (insert string))))
(set-process-sentinel
process
`(lambda (process string)
(unwind-protect
- (when (and (buffer-live-p (marker-buffer ,marker))
- (equal string "finished\n"))
- (let ((data
- (with-current-buffer (process-buffer process)
- (set-buffer-multibyte nil)
- (buffer-string))))
- (lsdb-insert-x-face-image data ',type ,marker)
- (lsdb-puthash ,x-face (list (cons ',type data))
- lsdb-x-face-cache)))
- (kill-buffer (process-buffer process))))))))
+ (if (equal string "finished\n")
+ (let ((data
+ (with-current-buffer ,buffer
+ (buffer-string))))
+ (lsdb-insert-face-image data ',type ,marker)
+ (lsdb-puthash ,face (list (cons ',type data))
+ lsdb-face-cache)))
+ (kill-buffer ,buffer))))
+ (process-send-string process (base64-decode-string face))
+ (process-send-eof process))))
(require 'product)
(provide 'lsdb)
(product-provide 'lsdb
- (product-define "LSDB" nil '(0 7)))
+ (product-define "LSDB" nil '(0 11)))
;;;_* Local emacs vars.
-;;; The following `outline-layout' local variable setting:
+;;; The following `allout-layout' local variable setting:
;;; - closes all topics from the first topic to just before the third-to-last,
;;; - shows the children of the third to last (config vars)
;;; - and the second to last (code section),
;;; - and closes the last topic (this local-variables section).
;;;Local variables:
-;;;outline-layout: (0 : -1 -1 0)
+;;;allout-layout: (0 : -1 -1 0)
;;;End:
;;; lsdb.el ends here
projects / elisp / lsdb.git / blobdiff