X-Git-Url: http://git.chise.org/gitweb/?p=elisp%2Flsdb.git;a=blobdiff_plain;f=lsdb.el;h=5c4b266a6ddb2ac3a28375c846d5bdc022ebaeb2;hp=7d7ecf7ce1d0022871d50d90883e7c65c5520dd0;hb=34eec3a166be2fbc1a79faa22d5c076bf6c34f47;hpb=1ea3e6ab81932e137c4b00f103914b5dfcdadf8f diff --git a/lsdb.el b/lsdb.el index 7d7ecf7..5c4b266 100644 --- a/lsdb.el +++ b/lsdb.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002 Daiki Ueno ;; Author: Daiki Ueno -;; Keywords: adress book +;; Keywords: address book ;; This file is part of the Lovely Sister Database. @@ -36,8 +36,8 @@ ;;; (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))) @@ -53,7 +53,7 @@ ;;; (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: @@ -91,7 +91,7 @@ :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") @@ -99,7 +99,9 @@ ("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) @@ -107,39 +109,22 @@ where the last three elements are optional." :group 'lsdb :type 'list) -(lsdb-define-entry 'net - :type '(list string) - :plist - (defcustom lsdb-entry-type-alist - '((net (list string)) - (creation-date string) - (last-modified string) - (mailing-list (list string)) - (attribution string) - (organization (list string)) - (www (list string)) - (aka (list string)) - (score integer) - (x-face (list string))) - "Alist mapping entry names to their types." - :group 'lsdb - :type 'list) - -(defcustom lsdb-entry--alist - '((net score 5) - (creation-date score 2) - (last-modified score 3) - (mailing-list 4) - (attribution 4) + '((net 5 ?,) + (creation-date 2 ?. t) + (last-modified 3 ?. t) + (mailing-list 4 ?,) + (attribution 4 ?.) (organization 4) (www 4) - (aka 4) + (aka 4 ?,) (score -1) - (x-face -1)) - "Alist of entry scores for presentation. + (x-face -1) + (face -1) + (sender -1)) + "Alist of entry types for presentation. The format of elements of this list should be - (ENTRY SCORE TYPE [PROP...]) + (ENTRY SCORE [CLASS READ-ONLY]) where the last two elements are optional. Possible values for CLASS are `?.' and '?,'. If CLASS is `?.', the entry takes a unique value which is overridden by newly assigned one @@ -168,13 +153,20 @@ The sender is passed to each function as the argument." :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" @@ -192,9 +184,14 @@ If non-nil, supersedes the return value of `lsdb-x-face-available-image-type'." :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." @@ -213,7 +210,40 @@ 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) @@ -223,6 +253,14 @@ The compressed face will be piped to this command." :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 @@ -253,6 +291,16 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"." :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))) @@ -312,6 +360,16 @@ It represents address to full-name mapping.") 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))) @@ -390,21 +448,30 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (save-excursion (goto-char marker) (if (looking-at "^#s(") - (progn - (forward-char 2) ;skip "#s" - (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 () @@ -435,11 +502,11 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." ;; 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 "))")) @@ -459,7 +526,8 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (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) @@ -470,17 +538,16 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (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) @@ -521,14 +588,15 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (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 @@ -547,6 +615,11 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (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 @@ -585,8 +658,10 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." ;;;_ : 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) @@ -615,7 +690,7 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (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)) @@ -625,25 +700,46 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (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)) @@ -702,26 +798,49 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (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)) @@ -763,12 +882,18 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." ;;;_ : 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 @@ -803,23 +928,23 @@ This is the current number of slots in HASH-TABLE, whether occupied or not." (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 @@ -916,7 +1041,9 @@ Modify whole identification by side effect." (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) @@ -975,6 +1102,12 @@ Modify whole identification by side effect." "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 @@ -1001,7 +1134,7 @@ Modify whole identification by side effect." (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) @@ -1028,7 +1161,7 @@ Modify whole identification by side effect." (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 @@ -1066,62 +1199,126 @@ Modify whole identification by side effect." (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 () @@ -1335,17 +1532,12 @@ of the buffer." (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 @@ -1366,11 +1558,9 @@ of the buffer." (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. @@ -1452,8 +1642,7 @@ always hide." (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) @@ -1463,8 +1652,7 @@ always hide." (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 @@ -1490,7 +1678,7 @@ always hide." (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 () @@ -1619,49 +1807,170 @@ the user wants it." (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