;;; (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:
: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
:group 'lsdb
:type 'string)
+(defcustom lsdb-verbose t
+ "If non-nil, confirm user to submit changes to lsdb-hash-table."
+ :type 'boolean
+ :group 'lsdb)
+
;;;_. Faces
(defface lsdb-header-face
'((t (:underline t)))
(eval-and-compile
(condition-case nil
- (progn
- ;; In XEmacs, hash tables can also be created by the lisp reader
- ;; using structure syntax.
- (read-from-string "#s(hash-table)")
- (defalias 'lsdb-read 'read))
+ (and
+ ;; In XEmacs, hash tables can also be created by the lisp reader
+ ;; using structure syntax.
+ (read-from-string "#s(hash-table)")
+ (defalias 'lsdb-read 'read))
(invalid-read-syntax
(defun lsdb-read (&optional marker)
"Read one Lisp expression as text from MARKER, return as Lisp object."
(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."
" test equal data (")
(lsdb-maphash
(lambda (key value)
- (insert (prin1-to-string key) " " (prin1-to-string value) " "))
+ (let (print-level print-length)
+ (insert (prin1-to-string key) " " (prin1-to-string value) " ")))
hash-table)
(insert "))"))
(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))
(if record
(progn
(setq net (car (cdr (assq 'net (cdr record)))))
- (if (equal net (car record))
+ (if (and net (equal net (car record)))
(setq lsdb-modeline-string net)
(setq lsdb-modeline-string (concat (car record) " <" net ">"))))
(setq lsdb-modeline-string ""))))
(defun lsdb-current-record ()
"Return the current record name."
- (let ((record (get-text-property (point) 'lsdb-record)))
- (unless record
- (error "There is nothing to follow here"))
- record))
+ (get-text-property (point) 'lsdb-record))
(defun lsdb-current-entry ()
- "Return the current entry name.
-If the point is not on a entry line, it prompts to select a entry in
-the current record."
+ "Return the current entry name in canonical form."
(save-excursion
(beginning-of-line)
- (if (looking-at "^[^\t]")
- (let ((record (lsdb-current-record))
- (completion-ignore-case t))
+ (if (looking-at "^\t\\([^\t][^:]+\\):")
+ (intern (downcase (match-string 1))))))
+
+(defun lsdb-read-entry (record &optional prompt)
+ "Prompt to select an entry in the given RECORD."
+ (let* ((completion-ignore-case t)
+ (entry-name
(completing-read
- "Which entry to modify: "
+ (or prompt
+ "Which entry: ")
(mapcar (lambda (entry)
(list (capitalize (symbol-name (car entry)))))
- (cdr record))))
- (end-of-line)
- (re-search-backward "^\t\\([^\t][^:]+\\):")
- (match-string 1))))
+ (cdr record))
+ nil t)))
+ (unless (equal entry-name "")
+ (intern (downcase entry-name)))))
+
+(defun lsdb-delete-entry (record entry)
+ "Delete given ENTRY from RECORD."
+ (setcdr record (delq entry (cdr record)))
+ (lsdb-puthash (car record) (cdr record)
+ lsdb-hash-table)
+ (run-hook-with-args 'lsdb-update-record-functions record)
+ (setq lsdb-hash-tables-are-dirty t))
(defun lsdb-mode-add-entry (entry-name)
"Add an entry on the current line."
(point))
(list 'lsdb-record record)))))))))
-(defun lsdb-mode-delete-entry (&optional entry-name dont-update)
+(defun lsdb-mode-delete-entry-1 (entry)
+ "Delete text contents of the ENTRY from the current buffer."
+ (save-restriction
+ (lsdb-narrow-to-record)
+ (let ((case-fold-search t)
+ (inhibit-read-only t)
+ buffer-read-only)
+ (goto-char (point-min))
+ (if (re-search-forward
+ (concat "^\t" (capitalize (symbol-name (car entry))) ":")
+ nil t)
+ (delete-region (match-beginning 0)
+ (if (re-search-forward
+ "^\t[^\t][^:]+:" nil t)
+ (match-beginning 0)
+ (point-max)))))))
+
+(defun lsdb-mode-delete-entry ()
"Delete the entry on the current line."
(interactive)
(let ((record (lsdb-current-record))
- entry)
- (or entry-name
- (setq entry-name (lsdb-current-entry)))
- (setq entry (assq (intern (downcase entry-name)) (cdr record)))
+ entry-name entry)
+ (unless record
+ (error "There is nothing to follow here"))
+ (setq entry-name (or (lsdb-current-entry)
+ (lsdb-read-entry record "Which entry to delete: "))
+ entry (assq entry-name (cdr record)))
(when (and entry
- (not dont-update))
- (setcdr record (delq entry (cdr record)))
- (lsdb-puthash (car record) (cdr record)
- lsdb-hash-table)
- (run-hook-with-args 'lsdb-update-record-functions record)
- (setq lsdb-hash-tables-are-dirty t))
- (save-restriction
- (lsdb-narrow-to-record)
- (let ((case-fold-search t)
- (inhibit-read-only t)
- buffer-read-only)
- (goto-char (point-min))
- (if (re-search-forward
- (concat "^\t" (or entry-name
- (lsdb-current-entry))
- ":")
- nil t)
- (delete-region (match-beginning 0)
- (if (re-search-forward
- "^\t[^\t][^:]+:" nil t)
- (match-beginning 0)
- (point-max))))))))
+ (or (not (interactive-p))
+ (not lsdb-verbose)
+ (y-or-n-p
+ (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-edit-entry ()
"Edit the entry on the current line."
(interactive)
- (let* ((record (lsdb-current-record))
- (entry-name (intern (downcase (lsdb-current-entry))))
- (entry (assq entry-name (cdr record)))
- (marker (point-marker)))
+ (let ((record (lsdb-current-record))
+ entry-name entry marker)
+ (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)
(save-excursion
(set-buffer lsdb-buffer-name)
(goto-char ,marker)
- (let* ((record (lsdb-current-record))
- (entry (assq ',entry-name (cdr record)))
- (inhibit-read-only t)
- buffer-read-only)
+ (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)))
(setcdr entry form)
(run-hook-with-args 'lsdb-update-record-functions record)
(setq lsdb-hash-tables-are-dirty t)
- (lsdb-mode-delete-entry (symbol-name ',entry-name) t)
+ (lsdb-mode-delete-entry-1 entry)
(beginning-of-line)
(add-text-properties
(point)
(message "(No changes need to be saved)")
(when (or (interactive-p)
dont-ask
+ (not lsdb-verbose)
(y-or-n-p "Save the LSDB now? "))
(lsdb-save-hash-tables)
(setq lsdb-hash-tables-are-dirty nil)
(lsdb-maphash
(if entry-name
(progn
- (unless (symbolp entry-name)
- (setq entry-name (intern (downcase entry-name))))
(lambda (key value)
(let ((entry (cdr (assq entry-name value)))
found)
(format "Search records `%s' regexp: " entry-name)
"Search records regexp: ")
nil nil nil 'lsdb-mode-lookup-history)
- entry-name)))
+ (if (and entry-name (not (equal entry-name "")))
+ (intern (downcase entry-name))))))
(lsdb-maybe-load-hash-tables)
(let ((records (lsdb-lookup-records regexp entry-name)))
(if records
(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
(provide 'lsdb)
(product-provide 'lsdb
- (product-define "LSDB" nil '(0 7)))
+ (product-define "LSDB" nil '(0 9)))
;;;_* Local emacs vars.
;;; The following `outline-layout' local variable setting:
projects / elisp / lsdb.git / blobdiff