From: hmurata Date: Mon, 17 Jan 2005 09:54:55 +0000 (+0000) Subject: * wl-mime.el (wl-draft-preview-attributes-list): New function. X-Git-Tag: wl-2_14-root~85 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=4ea30d3c56d9fe6ec7a48c8dd05ba0894d3e8028;p=elisp%2Fwanderlust.git * wl-mime.el (wl-draft-preview-attributes-list): New function. (wl-draft-show-attributes-buffer): Ditto. (wl-draft-hide-attributes-buffer): Ditto. (wl-draft-attribute-newsgroups): Ditto. (wl-draft-attribute-nntp-posting-server): Ditto. (wl-draft-attribute-nntp-posting-port): Ditto. (wl-draft-preview-message): Use there functions. * wl-vars.el (wl-draft-preview-attributes-list): Change default value. --- diff --git a/wl/ChangeLog b/wl/ChangeLog index bc0415d..92430e5 100644 --- a/wl/ChangeLog +++ b/wl/ChangeLog @@ -1,3 +1,16 @@ +2005-01-17 Hiroya Murata + + * wl-mime.el (wl-draft-preview-attributes-list): New function. + (wl-draft-show-attributes-buffer): Ditto. + (wl-draft-hide-attributes-buffer): Ditto. + (wl-draft-attribute-newsgroups): Ditto. + (wl-draft-attribute-nntp-posting-server): Ditto. + (wl-draft-attribute-nntp-posting-port): Ditto. + (wl-draft-preview-message): Use there functions. + + * wl-vars.el (wl-draft-preview-attributes-list): Change default + value. + 2005-01-11 Hiroya Murata * wl-draft.el (wl-draft-insert-get-message): Follow the API change. diff --git a/wl/wl-mime.el b/wl/wl-mime.el index 7144c28..6e2f2be 100644 --- a/wl/wl-mime.el +++ b/wl/wl-mime.el @@ -176,6 +176,51 @@ It calls following-method selected from variable (defalias 'wl-draft-enclose-digest-region 'mime-edit-enclose-digest-region) +(defun wl-draft-preview-attributes-list () + (if (listp (car wl-draft-preview-attributes-list)) + (elmo-uniq-list + (append (and (wl-message-mail-p) + (cdr (assq 'mail wl-draft-preview-attributes-list))) + (and (wl-message-news-p) + (cdr (assq 'news wl-draft-preview-attributes-list))))) + wl-draft-preview-attributes-list)) + +(defun wl-draft-show-attributes-buffer (attribute-values) + (let* ((cur-win (selected-window)) + (size (min + (- (window-height cur-win) + window-min-height 1) + (- (window-height cur-win) + (max + window-min-height + (1+ wl-draft-preview-attributes-buffer-lines)))))) + (split-window cur-win (if (> size 0) size window-min-height)) + (select-window (next-window)) + (let ((pop-up-windows nil)) + (switch-to-buffer (get-buffer-create + wl-draft-preview-attributes-buffer-name))) + (with-current-buffer + (get-buffer wl-draft-preview-attributes-buffer-name) + (setq buffer-read-only t) + (let (buffer-read-only) + (erase-buffer) + (dolist (pair attribute-values) + (insert (capitalize (symbol-name (car pair))) ": " + (format "%s" (or (cdr pair) "")) + "\n")) + (goto-char (point-min)) + (wl-highlight-headers))) + (select-window cur-win))) + +(defun wl-draft-hide-attributes-buffer () + (let (window buffer) + (when (setq window (get-buffer-window + wl-draft-preview-attributes-buffer-name)) + (select-window window) + (delete-window)) + (when (setq buffer (get-buffer wl-draft-preview-attributes-buffer-name)) + (kill-buffer buffer)))) + (defun wl-draft-attribute-recipients () (concat (mapconcat 'identity @@ -206,6 +251,15 @@ It calls following-method selected from variable (or wl-smtp-posting-port (progn (require 'smtp) smtp-service))) +(defun wl-draft-attribute-newsgroups () + (std11-field-body "Newsgroups")) + +(defun wl-draft-attribute-nntp-posting-server () + (or wl-nntp-posting-server elmo-nntp-default-server)) + +(defun wl-draft-attribute-nntp-posting-port () + (or wl-nntp-posting-port elmo-nntp-default-port)) + (defun wl-draft-attribute-value (attr) (let ((name (symbol-name attr)) fsymbol symbol) @@ -235,7 +289,7 @@ It calls following-method selected from variable (defun wl-draft-preview-message () "Preview editing message." (interactive) - (let* (attribute-list + (let* (attribute-values (orig-buffer (current-buffer)) (current-point (point)) (config-exec-flag wl-draft-config-exec-flag) @@ -249,29 +303,30 @@ It calls following-method selected from variable (symbol-value 'mime-header-encode-method-alist)))) mime-view-ignored-field-list ; all header. (mime-edit-translate-buffer-hook - (append - (list - (lambda () - (let ((wl-draft-config-exec-flag config-exec-flag) - (wl-draft-parent-folder parent-folder) - (copy-buffer (current-buffer))) + (cons + (lambda () + (let ((wl-draft-config-exec-flag config-exec-flag) + (wl-draft-parent-folder parent-folder) + (copy-buffer (current-buffer))) + (wl-copy-local-variables + orig-buffer + copy-buffer (with-current-buffer orig-buffer - (wl-copy-local-variables - orig-buffer - copy-buffer - (append wl-draft-config-variables - (wl-draft-clone-local-variables)))) - (goto-char current-point) - (run-hooks 'wl-draft-send-hook) - (condition-case err - (setq attribute-list - (mapcar - (lambda (attr) - (cons attr (wl-draft-attribute-value attr))) - wl-draft-preview-attributes-list)) - (error - (kill-buffer (current-buffer)) - (signal (car err) (cdr err))))))) + (append wl-draft-config-variables + (wl-draft-clone-local-variables)))) + (goto-char current-point) + (run-hooks 'wl-draft-send-hook) + (condition-case err + (setq attribute-values + (mapcar + (lambda (attr) + (cons attr (wl-draft-attribute-value attr))) + (if wl-draft-preview-attributes + (wl-draft-preview-attributes-list) + '(recipients)))) + (error + (kill-buffer (current-buffer)) + (signal (car err) (cdr err)))))) mime-edit-translate-buffer-hook))) (mime-edit-preview-message) (make-local-variable 'mime-preview-quitting-method-alist) @@ -282,46 +337,12 @@ It calls following-method selected from variable (wl-highlight-body)) (run-hooks 'wl-draft-preview-message-hook)) (make-local-hook 'kill-buffer-hook) - (add-hook 'kill-buffer-hook - (lambda () - (when (get-buffer-window - wl-draft-preview-attributes-buffer-name) - (select-window (get-buffer-window - wl-draft-preview-attributes-buffer-name)) - (delete-window)) - (when (get-buffer wl-draft-preview-attributes-buffer-name) - (kill-buffer (get-buffer - wl-draft-preview-attributes-buffer-name)))) - nil t) - (if (not wl-draft-preview-attributes) - (message (concat "Recipients: " - (cdr (assq 'recipients attribute-list)))) - (ignore-errors ; in case when the window is too small - (let* ((cur-win (selected-window)) - (size (min - (- (window-height cur-win) - window-min-height 1) - (- (window-height cur-win) - (max - window-min-height - (1+ wl-draft-preview-attributes-buffer-lines)))))) - (split-window cur-win (if (> size 0) size window-min-height)) - (select-window (next-window)) - (let ((pop-up-windows nil)) - (switch-to-buffer (get-buffer-create - wl-draft-preview-attributes-buffer-name))) - (with-current-buffer - (get-buffer wl-draft-preview-attributes-buffer-name) - (setq buffer-read-only t) - (let (buffer-read-only) - (erase-buffer) - (dolist (pair attribute-list) - (insert (capitalize (symbol-name (car pair))) ": " - (format "%s" (or (cdr pair) "")) - "\n")) - (goto-char (point-min)) - (wl-highlight-headers))) - (select-window cur-win)))))) + (add-hook 'kill-buffer-hook #'wl-draft-hide-attributes-buffer nil t) + (if wl-draft-preview-attributes + (ignore-errors ; in case when the window is too small + (wl-draft-show-attributes-buffer attribute-values)) + (message (concat "Recipients: " + (cdr (assq 'recipients attribute-values))))))) (defalias 'wl-draft-caesar-region 'mule-caesar-region) diff --git a/wl/wl-vars.el b/wl/wl-vars.el index abc6af0..6aea055 100644 --- a/wl/wl-vars.el +++ b/wl/wl-vars.el @@ -1990,21 +1990,28 @@ Attributes specified in the `wl-draft-preview-attributes-list' are displayed." :type 'boolean :group 'wl-draft) -(defcustom wl-draft-preview-attributes-list '(recipients - envelope-from - smtp-posting-server - smtp-posting-port) +(defcustom wl-draft-preview-attributes-list '((mail recipients + envelope-from + smtp-posting-server + smtp-posting-port) + (news newsgroups + nntp-posting-server + nntp-posting-port)) "*Attribute symbols to display in the draft preview. Candidates are following: `recipients' `envelope-from' `smtp-posting-server' `smtp-posting-port' +`newsgroups' `nntp-posting-server' `nntp-posting-port' Also variables which begin with `wl-' can be specified \(`wl-' have to be removed\)" - :type '(repeat symbol) + :type '(choice (repeat (cons (choice (const :tag "Mail" mail) + (const :tag "News" news)) + (repeat symbol))) + (repeat symbol)) :group 'wl-draft) (defcustom wl-draft-preview-attributes-buffer-lines 5