Description: contribution files to Mew Forked to to maintain patches. Added mew-nmz.el from . Added mew-absfilter.el from . Origin: upstream, https://github.com/kazu-yamamoto/mew-contrib diff -urN mew.orig/contrib/mew-absfilter.el mew/contrib/mew-absfilter.el --- mew.orig/contrib/mew-absfilter.el 1970-01-01 09:00:00.000000000 +0900 +++ mew/contrib/mew-absfilter.el 2011-06-20 01:46:19.000000000 +0900 @@ -0,0 +1,476 @@ +;;; mew-absfilter.el --- spam filter with bsfilter for Mew + +;; Author: SAITO Takuya +;; $Id$ + +;; You can use, copy, distribute, and/or modify this file for any purpose. +;; There is NO WARRANTY. + +;;; Commentary: + +;; You can find bsfilter at http://bsfilter.org/ + +;; To enable spam check after retrieve, put below into your ~/.emacs: +;; (mew-absfilter-mode 1) + +;; If you want to do spam checking after shimbun retrieve, +;; do not use `mew-shimbun-retrieve-all' because it kills the shimbun buffer. + +;; When you find bsfilter marks the clean message as spam, +;; use "bc" (mew-absfilter-learn-clean) instead of "u" (mew-summary-undo) + +;; With "bx" (mew-absfilter-summary-exec-spam), you can process spam mark +;; even in nntp. + +;;; History: +;; v1.38, 2006-06-11 +;; Masayuki Ataka Support Mew 5 +;; v1.39, 2007-01-17 +;; Masayuki Ataka Support non-nil mew-use-suffix +;; v1.40, 2007-01-28 +;; SAITO Takuya tiny fix + +;;; Code: + +(require 'mew) + +;;; spam mark +(defvar mew-absfilter-mark-spam ?\;) + +(defvar mew-absfilter-spam-folder "+spam" + "*Spam folder. Must be a local folder.") + +(defface mew-absfilter-face-mark-spam + '((((class color) (type tty)) (:foreground "green")) + (((class color) (background light)) (:foreground "DimGray")) + (((class color) (background dark)) (:foreground "gray")) + (t nil)) + "*Face to highlight the spam mark" + :group 'mew-highlight) + +(defun mew-absfilter-mark-kill-spam (src msg) + "Return t if kill summary line." + (not (string= src mew-absfilter-spam-folder))) + +(defun mew-absfilter-mark-exec-spam (src msgs) + "Refile MSGs from the SRC folder to `mew-absfilter-spam-folder'." + (unless (string= src mew-absfilter-spam-folder) + (let ((mew-trash-folder mew-absfilter-spam-folder) + (mew-trash-folder-list nil)) + (mew-mark-exec-delete src msgs)))) + +(defun mew-absfilter-summary-spam-one (&optional no-msg) + "Put the spam mark(default is ';') on this message." + (mew-mark-put-mark mew-absfilter-mark-spam no-msg 'valid-only)) + +;; register spam mark +(add-to-list 'mew-mark-afterstep-spec + (list mew-absfilter-mark-spam 2 2 2 2 0 2 0)) +(add-to-list 'mew-mark-spec + (list mew-absfilter-mark-spam "spam" 2 nil + 'mew-absfilter-mark-kill-spam nil + 'mew-absfilter-mark-exec-spam nil)) +(add-to-list 'mew-highlight-mark-keywords + (cons mew-absfilter-mark-spam 'mew-absfilter-face-mark-spam)) + + +(defvar mew-absfilter-program "bsfilter") +(defvar mew-absfilter-arg-check '("--quiet" "--list-spam")) +(defvar mew-absfilter-arg-clean '("--sub-spam" "--add-clean" "--update")) +(defvar mew-absfilter-arg-spam '("--sub-clean" "--add-spam" "--update")) + +(defvar mew-absfilter-spam-folder-max-msgs 3000) + +;; like mew-prog-grep-max-msgs +(defvar mew-absfilter-max-msgs 10000) + +(defvar mew-absfilter-map + (let ((map (make-sparse-keymap))) + (define-key map "c" 'mew-absfilter-learn-clean) + (define-key map "s" 'mew-absfilter-learn-spam) + (define-key map "C" 'mew-absfilter-mark-learn-clean) + (define-key map "S" 'mew-absfilter-mark-learn-spam) + (define-key map "b" 'mew-absfilter-check-spam) + (define-key map "x" 'mew-absfilter-summary-exec-spam) + (define-key map "D" 'mew-absfilter-clean-spam-folder) + map)) + +(define-key mew-summary-mode-map "b" mew-absfilter-map) +;; (define-key mew-summary-mode-map +;; [remap mew-summary-learn-spam] 'mew-absfilter-learn-spam) +;; (define-key mew-summary-mode-map +;; [remap mew-summary-learn-ham] 'mew-absfilter-learn-clean) + + +(defvar mew-absfilter-summary-buffer-process nil) +(make-variable-buffer-local 'mew-absfilter-summary-buffer-process) +;; Use buffer-local-variable in process-buffer. +;; process-{put,get} is avairable only in Emacs-21.4 or above. +(defvar mew-absfilter-process-folder nil) + +(defun mew-absfilter-add-clean (files) + (apply 'call-process + mew-absfilter-program nil 0 nil + (append mew-absfilter-arg-clean files))) + +(defun mew-absfilter-add-spam (files) + (apply 'call-process + mew-absfilter-program nil 0 nil + (append mew-absfilter-arg-spam files))) + +(defmacro mew-absfilter-expand-msg (folder msg) + "Expand message MSG in FOLDER. +Function `mew-expand-msg' is defined after Mew 4.2.53. +Use `mew-expand-folder' iff `mew-expand-msg' is not available." + (if (fboundp 'mew-expand-msg) + `(mew-expand-msg ,folder ,msg) + `(mew-expand-folder ,folder ,msg))) + +(defmacro mew-absfilter-sumsyn-filename () + "Get filename" + (if (fboundp 'mew-msg-get-filename) + `(mew-msg-get-filename (mew-sumsyn-message-number)) + `(mew-sumsyn-message-number))) + +(defun mew-absfilter-match-string-message-number () + (if (and (boundp 'mew-use-suffix) + (boundp 'mew-suffix)) + (mew-match-string 1) + (mew-match-string 0))) + +;; spam check +(defun mew-absfilter-collect-message-region (begin end) + "Returns a list of message file name in region." + (when (> end begin) + (let (msgs) + (save-excursion + (save-restriction + (narrow-to-region begin end) + (goto-char (point-min)) + (while (not (eobp)) + (when (and (mew-summary-markable) + (mew-sumsyn-match mew-regex-sumsyn-short)) + (push (mew-absfilter-sumsyn-filename) msgs)) + (forward-line)))) + (nreverse msgs)))) + +(defun mew-absfilter-collect-spam-message () + (let (spam) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when (looking-at mew-regex-message-files2) + (push (mew-absfilter-match-string-message-number) spam)) + (forward-line))) + (nreverse spam))) + +(defun mew-absfilter-check-spam-region (case:folder begin end) + (with-current-buffer case:folder + (mew-pickable + (let ((msgs (mew-absfilter-collect-message-region begin end)) + nxt) + (when msgs + (message "Spam checking %s..." case:folder)) + (while msgs + (let ((buf (get-buffer-create + (generate-new-buffer-name " *mew bsfilter*"))) + process) + (with-current-buffer buf + (cd (mew-expand-folder case:folder)) + (mew-erase-buffer) + (set (make-local-variable 'mew-absfilter-process-folder) + case:folder)) + (setq nxt (nthcdr mew-absfilter-max-msgs msgs)) + (when nxt + (setcdr (nthcdr (1- mew-absfilter-max-msgs) msgs) nil)) + (setq process (apply 'start-process "mew-absfilter" buf + mew-absfilter-program + (append mew-absfilter-arg-check msgs))) + (set-process-sentinel process 'mew-absfilter-sentinel) + (add-to-list 'mew-absfilter-summary-buffer-process process)) + (setq msgs nxt))))) + (when mew-absfilter-summary-buffer-process + (force-mode-line-update))) + +(defun mew-absfilter-apply-spam-action (case:folder spam) + (when (and spam + (get-buffer case:folder)) + (save-excursion + (let ((vfolder (mew-folder-to-thread case:folder))) + ;; mark in thread if exists + (when (and (get-buffer vfolder) + (mew-virtual-thread-p vfolder) + (with-current-buffer case:folder + (mew-thread-cache-valid-p vfolder))) + (let ((msgs spam)) + (setq spam nil) + (set-buffer vfolder) + (save-excursion + (dolist (msg msgs) + (if (or (re-search-forward (mew-regex-sumsyn-msg msg) nil t) + (re-search-backward (mew-regex-sumsyn-msg msg) nil t)) + (mew-absfilter-summary-spam-one 'no-msg) + ;; if msg is not found, try to mark in physical folder + (push msg spam))))))) + (when spam + (set-buffer case:folder) + (save-excursion + (dolist (msg spam) + (when (or (re-search-forward (mew-regex-sumsyn-msg msg) nil t) + (re-search-backward (mew-regex-sumsyn-msg msg) nil t)) + (mew-absfilter-summary-spam-one 'no-msg)))))))) + +(defun mew-absfilter-sentinel (process event) + ;; exit status of "bsfilter --list-spam" + ;; 0: some spams are found + ;; 1: spam not found + (mew-filter + (let ((status (process-exit-status process)) + (case:folder mew-absfilter-process-folder) + (spam (mew-absfilter-collect-spam-message))) + (when (zerop status) + (mew-absfilter-apply-spam-action case:folder spam)) + (with-current-buffer case:folder + (setq mew-absfilter-summary-buffer-process + (delq process mew-absfilter-summary-buffer-process))) + (message "Spam checking %s...%s" + case:folder + (cond + ((= status 0) + (format "done (%d spam)" (length spam))) + ((= status 1) + (concat "done (spam not found)")) + (t + (concat "failed. " event)))) + (kill-buffer (current-buffer))))) + +;; commands +(defun mew-absfilter-learn-clean (&optional mark-only) + "Learn this message as clean (not spam)." + (interactive "P") + (mew-summary-msg-or-part + (mew-summary-goto-message) + (when (mew-sumsyn-match mew-regex-sumsyn-short) + (let* ((msg (mew-sumsyn-message-number)) + (case:folder (mew-sumsyn-folder-name)) + (file (mew-absfilter-expand-msg case:folder msg))) + (when (eq (mew-summary-get-mark) mew-absfilter-mark-spam) + (mew-summary-undo)) + (unless mark-only + (mew-absfilter-add-clean (list file)) + (message "Learned as clean")))))) + +(defun mew-absfilter-learn-spam (&optional mark-only) + "Learn this message as spam." + (interactive "P") + (mew-summary-msg-or-part + (mew-summary-goto-message) + (when (mew-sumsyn-match mew-regex-sumsyn-short) + (let* ((msg (mew-sumsyn-message-number)) + (case:folder (mew-sumsyn-folder-name)) + (file (mew-absfilter-expand-msg case:folder msg))) + (mew-absfilter-summary-spam-one) + (unless mark-only + (mew-absfilter-add-spam (list file)) + (message "Learned as spam")))))) + +(defun mew-absfilter-mark-learn-clean (&optional mark-only) + "Learn all messages marked with '*' as clean (not spam)." + (interactive "P") + (mew-summary-multi-msgs + (mew-mark-undo-mark mew-mark-review) + (unless mark-only + (message "Learning as clean...") + (mew-absfilter-add-clean FILES) + (message "Learning as clean...done")))) + +(defun mew-absfilter-mark-learn-spam (&optional mark-only) + "Learn all messages marked with '*' as spam." + (interactive "P") + (mew-summary-multi-msgs + (mew-mark-undo-mark mew-mark-review) + (unless mark-only + (message "Learning as spam...") + (mew-absfilter-add-spam FILES) + (message "Learning as spam...done")))) + +;; (defun mew-absfilter-thread-mark-learn-spam () +;; "Put the ';' mark on all messages of the current sub-thread." +;; (interactive) +;; (mew-thread-mark mew-absfilter-mark-spam 'valid-only)) + +(defun mew-absfilter-summary-exec-spam () + "Process messages marked with ';'." + (interactive) + (let* ((ent (assoc mew-absfilter-mark-spam mew-mark-spec)) + (mew-mark-spec (list ent))) + ;; call `mew-summary-exec-local' even for imap or nntp + (cond + ((mew-virtual-p) + (mew-summary-go-back-summary + (mew-substitute-for-summary "\\[mew-summary-exec]"))) + (t + ;; This message can not be changed because + ;; (message "Refiling and deleting...done") is called in + ;; `mew-summary-exec-local'. + (message "Refiling and deleting...") + (force-mode-line-update) + (mew-summary-exec-local (point-min) (point-max)))))) + +(defun mew-absfilter-check-spam (&optional arg) + "Check spam messages with bsfilter." + (interactive "P") + (let ((region (if (or arg (mew-mark-active-p)) + (mew-summary-get-region) + (cons (point-min) (point-max))))) + (mew-absfilter-check-spam-region (mew-summary-folder-name 'ext) + (car region) (cdr region)))) + +(defun mew-absfilter-clean-spam-folder (&optional unlink) + "Remove old spam. +Save `mew-absfilter-spam-folder-max-msgs' messages." + (interactive "P") + (mew-summary-visit-folder mew-absfilter-spam-folder) + (mew-rendezvous mew-summary-buffer-process) + (mew-decode-syntax-delete) + (save-excursion + (goto-char (point-max)) + (forward-line (- mew-absfilter-spam-folder-max-msgs)) + (let ((pos (point))) + (while (zerop (forward-line -1)) + (mew-summary-mark-as (if unlink mew-mark-unlink mew-mark-delete))) + (mew-summary-exec-region (point) pos)))) + + +;;; Check after retrieve +(defvar mew-absfilter-check t + "When to check with bsfilter. +If t, do full check. Otherwise, the value should be a list whose element +is one of `local', `pop', `imap', `nntp', or `shimbun'.") + +;; biff scan inc sync exec get list jobs +(defvar mew-absfilter-check-directive-list '(("+" inc) + ("$" . nil) + ("%" inc scan) + ("-" scan))) + +;; Suppress byte-compiler warning. +;; bnm and directive is local variable which can be used in +;; mew-{local,pop,imap,nntp}-sentinel. +(defvar bnm) +(defvar directive) + +(defun mew-absfilter-check-spam-after-retrieve () + "Check spam messages with bsfilter after retrieve." + (when (stringp bnm) + (let* ((proto (mew-folder-prefix (mew-case:folder-folder bnm))) + (check (cdr (assoc proto mew-absfilter-check-directive-list)))) + (when (memq directive check) + (with-current-buffer bnm + (mew-absfilter-check-spam-region bnm + (mew-sinfo-get-start-point) + (point-max))))))) + +;; mew-local-sentinel does not let-bind `directive' +;; and that information is lost by (mew-info-clean-up pnm) +;; when mew-scan-sentinel-hook is called. +(defadvice mew-local-sentinel (around absfilter-check disable) + "Bind `directive' for spam checking. +Advised in mew-absfilter.el" + (let ((directive (mew-local-get-directive (process-name process)))) + ad-do-it)) + +;; Check after `mew-shimbun-retrieve' +(defun mew-absfilter-shimbun-retrieve-set-start-point () + "Set retrieve start point." + (mew-sinfo-set-start-point (point-max))) + +(defun mew-absfilter-check-spam-after-shimbun-retrieve () + "Check spam messages with absfilter after shimbun-retrieve." + (mew-absfilter-check-spam-region (mew-summary-folder-name 'ext) + (mew-sinfo-get-start-point) (point-max))) + +;; modeline +(defadvice mew-summary-setup-mode-line (after absfilter-process disable) + "Display \"bsfilter\" in mode line. +Advised in mew-absfilter.el" + (add-to-list 'mode-line-process + (list 'mew-absfilter-summary-buffer-process " bsfilter"))) + +;; inhibit pack, exec +(defadvice mew-summary-exclusive-p (after absfilter-process disable) + "Return nil when operation may break marking spam. +`mew-absfilter-apply-spam-action' may put spam mark on the wrong message +if message number is changed during bsfilter is running. +The example of such operations are: + - \"O\" (mew-summary-pack) + - 'Refile' + \"i\" (mew-summary-retrieve) + +Advised in mew-absfilter.el" + (when (and mew-absfilter-summary-buffer-process + (memq this-command '(mew-summary-exec mew-summary-pack))) + (unless no-msg + (message "bsfilter is running. Try again later")) + (setq ad-return-value nil))) + +(defun mew-absfilter-mode-activate (initialize) + (let ((all '(local pop imap nntp shimbun)) + ad-func hook-func) + (when (eq initialize t) + (setq initialize all)) + (if initialize + (setq ad-func 'ad-enable-advice + hook-func 'add-hook) + (setq initialize all + ad-func 'ad-disable-advice + hook-func 'remove-hook)) + (when (memq 'local initialize) + (funcall ad-func 'mew-local-sentinel 'around 'absfilter-check) + (ad-activate 'mew-local-sentinel) + (funcall hook-func + 'mew-scan-sentinel-hook + 'mew-absfilter-check-spam-after-retrieve)) + (when (memq 'pop initialize) + (funcall hook-func + 'mew-pop-sentinel-non-biff-hook + 'mew-absfilter-check-spam-after-retrieve)) + (when (memq 'imap initialize) + (funcall hook-func + 'mew-imap-sentinel-non-biff-hook + 'mew-absfilter-check-spam-after-retrieve)) + (when (memq 'nntp initialize) + (funcall hook-func + 'mew-nntp-sentinel-hook + 'mew-absfilter-check-spam-after-retrieve)) + (when (memq 'shimbun initialize) + (funcall hook-func + 'mew-shimbun-before-retrieve-hook + 'mew-absfilter-shimbun-retrieve-set-start-point) + (funcall hook-func + 'mew-shimbun-retrieve-hook + 'mew-absfilter-check-spam-after-shimbun-retrieve)) + (funcall ad-func 'mew-summary-setup-mode-line 'after 'absfilter-process) + (funcall ad-func 'mew-summary-exclusive-p 'after 'absfilter-process) + (ad-activate 'mew-summary-setup-mode-line) + (ad-activate 'mew-summary-exclusive-p))) + +(defvar mew-absfilter-mode nil) +;;;###autoload +(defun mew-absfilter-mode (&optional arg) + "Enable or disable bsfilter checking. +See `mew-absfilter-check' when bsfilter is run." + (interactive "P") + (let ((mode (if arg + (> (prefix-numeric-value arg) 0) + (not mew-absfilter-mode)))) + (when (and mode + (not (mew-which-exec mew-absfilter-program))) + (error "`%s' not found" mew-absfilter-program)) + (setq mew-absfilter-mode mode) + (mew-absfilter-mode-activate (if mode mew-absfilter-check)) + (when (interactive-p) + (message "bsfilter checking is %s" (if mode "enabled" "disabled"))))) + +(provide 'mew-absfilter) + +;;; mew-absfilter.el ends here diff -urN mew.orig/contrib/mew-browse.el mew/contrib/mew-browse.el --- mew.orig/contrib/mew-browse.el 1970-01-01 09:00:00.000000000 +0900 +++ mew/contrib/mew-browse.el 2011-06-15 00:20:15.000000000 +0900 @@ -0,0 +1,343 @@ +;;; mew-browse.el --- Handling URI with browse-url.el + +;; Author: Hideyuki SHIRAI +;; Modify: Shuichi Kitaguchi +;; Created: May 19, 1999 +;; Revised: Nov 08, 2004 + +;;; +;;; ~/.emacs settings. +;;; +;;; ... anything browse-url setting ... +;; (require 'mew-browse) + +;;; SHIFT + (Middle|Right)-Click = browse-url or mew-user-agent-compose +;;; for Emacs +;; (define-key global-map [S-mouse-2] 'browse-url-at-mouse) +;;; for XEmacs +;; (define-key global-map [(shift button2)] 'browse-url-at-mouse) +;; + +;;; Appending URI to specified file. +;; +;; mew-browse-noask ... ask or not when browse +;; mew-browse-append-file ... URL collection file name +;; mew-browse-append-always-file ... always, append URL to file (for dial-up) +;; mew-browse-append-always-mailto ... always, URL is mailto: (for emacs19.28) +;; mew-browse-append-file-sort ... always, sort URL file +;; +;;; example: +;; (setq mew-browse-noask nil) +;; (setq mew-browse-append-file "~/.browse") +;; (setq mew-browse-append-always-file nil) +;; (setq mew-browse-append-always-mailto nil) +;; (setq mew-browse-append-file-sort nil) +;; + +;;; Use mew-url-mailto instead of url-mailto in W3, add followings in your ~/.emacs file. +;; +;; (cond +;; ((locate-library "url-mail") +;; (eval-after-load "url-mail" +;; '(fset 'url-mailto (symbol-function 'mew-url-mailto)))) +;; ((locate-library "url") +;; (eval-after-load "url" +;; '(fset 'url-mailto (symbol-function 'mew-url-mailto))))) +;; + +;;; Use from emacs-w3m, add followings in your ~/.emacs file. +;; (setq w3m-mailto-url-function 'mew-url-mailto) +;; + +;;; Use from MS-Windows application, set followings in your registry. +;; registry key: '\\HKEY_LOCAL_MACHINE\\SOFTWARE\\Classes\\mailto\\shell\\open\\command' +;; registry value: 'drive:\\path\\gnudoitw.exe \"(mew-url-mailto \"%%1\")\"'" +;; + +;;; Use from Mozilla & Firefox with MozEx, set followings on Mailer form of MozEx. +;; "/path/gnudoit (mew-url-mailto-mozex "%r")" +;; or +;; "/path/emacseval (mew-url-mailto-mozex "%r")" +;; +;; `emacseval' is a shell script like this, +;; ----cut here---- +;; #!/bin/sh +;; /usr/local/bin/emacsclient --eval "`echo $*`" +;; ----cut here----" +;; + +(eval-when-compile (require 'mew)) + +(if (string-match "XEmacs" emacs-version) + (defvar mew-browse-button [(button2)] "*Mouse button in message mode.") + (defvar mew-browse-button [mouse-2] "*Mouse button in message mode.")) + +(defvar mew-ext-prog-url mew-prog-text/html-ext) +(defvar mew-ext-prog-url-args nil) + +(setq browse-url-browser-function 'mew-browse-url) + +(defvar mew-browse-url-mailto-switch-func nil + "*Which do you like, nil, 'switch-to-buffer-other-window or 'switch-to-buffer-other-frame ?") + +(setq browse-url-regexp "\\(\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]+\\)\\|\\(\\([^-A-Za-z0-9!_.%]\\|^\\)[-A-Za-z0-9._!%]+@[A-Za-z0-9][-A-Za-z0-9._!]+[A-Za-z0-9]\\)") + +(defvar mew-browse-noask t "*Ask or not when browse.") +(defvar mew-browse-append-file nil "*URL collection file.") +(defvar mew-browse-append-always-file nil "*For dialup user.") +(defvar mew-browse-append-always-mailto nil "*For emacs19.28.") +(defvar mew-browse-append-file-sort nil "*Sort URL file.") + +(defun mew-browse-url (url &optional args) + "Exec browse URL or mew-user-agent-compose with parsing RFC2368." + (interactive + (list (read-from-minibuffer "Mew URL: "))) + (when (or (not (boundp 'mew-init-p)) (null mew-init-p)) + (save-excursion + (require 'mew) + (mew-init))) + (let* ((append-buffer (and mew-browse-append-file + (string= buffer-file-name + (expand-file-name mew-browse-append-file)))) + (append-nil (or append-buffer (not mew-browse-append-file))) + (append-all (and (not append-nil) mew-browse-append-always-file)) + (append-ask (and (not append-nil) (not mew-browse-append-always-file))) + (browse-all (or append-buffer mew-browse-noask)) + (browse-ask (and (not append-buffer) (not mew-browse-noask)))) + (string-match "\\([a-zA-Z0-9][-a-zA-Z0-9!_=?#$@~`%&*+|\\/.,:]+\\)" url) + (setq url (substring url (match-beginning 0) (match-end 0))) + (unless (string-match ":" url) ;; emacs19.28 only + (if (and (not mew-browse-append-always-mailto) + (not (y-or-n-p (format "mailto:%s(y) or ftp://%s(n)? " url url)))) + (setq url (concat "ftp://" url)) + (setq url (concat "mailto:" url)))) + (cond + ((and append-all browse-all) + (mew-browse-url-append url) + (mew-browse-url-start url)) + ((and append-ask browse-all) + (when (y-or-n-p (format "Append %s? " url)) + (mew-browse-url-append url)) + (mew-browse-url-start url)) + ((and append-nil browse-all) + (mew-browse-url-start url)) + ((and append-all browse-ask) + (mew-browse-url-append url) + (when (y-or-n-p (format "Browse %s? " url)) + (mew-browse-url-start url))) + ((and append-nil browse-ask) + (when (y-or-n-p (format "Browse %s? " url)) + (mew-browse-url-start url))) + (t ;; (and append-ask browse-ask) + (if (y-or-n-p (format "Browse %s(y) or Append(n)? " url)) + (mew-browse-url-start url) + (mew-browse-url-append url))) + ))) + +(defun mew-browse-url-append (url) + (let ((file (expand-file-name mew-browse-append-file)) + (beg)) + (save-excursion + (find-file file) + (set-buffer (current-buffer)) + (goto-char (point-min)) + (while (search-forward url nil t) + (progn + (beginning-of-line) + (setq beg (point)) + (forward-line) + (delete-region beg (point)))) + (goto-char (point-max)) + (insert url "\n") + (when mew-browse-append-file-sort + (sort-lines nil (point-min) (point-max))) + (write-file file) + (kill-buffer (current-buffer)) + (message "Append %s to %s done" url file) + ))) + +(defun mew-browse-url-start (url) + (message "Browse %s" url) + (cond + ((string-match "^mailto:" url) + (mew-url-mailto url)) + ((and (symbolp mew-ext-prog-url) (fboundp mew-ext-prog-url)) + (funcall mew-ext-prog-url url)) + ((equal mew-ext-prog-url "w3") + (require 'w3) + (w3-fetch-other-frame url)) + (t + (let ((orig mew-ext-prog-url-args) + args replace) + (while orig + (if (string-match "%s" (car orig)) + (progn + (setq args (cons (format (car orig) url) args)) + (setq esqp t) + (setq replace t)) + (setq args (cons (car orig) args))) + (setq orig (cdr orig))) + (setq args (nreverse args)) + (apply (function start-process) + (format "*mew %s*" mew-ext-prog-url) + nil mew-ext-prog-url + (if replace + args + (append args (list url)))))))) + +(defun mew-url-mailto (url) + "Execute mew-user-agent-compose with parsing RFC2368. + +If use from emacs-w3m, add followings in your ~/.emacs file. + (setq w3m-mailto-url-function 'mew-url-mailto) + +If use from MS-Windows application, set followings in your registry. + registry key: '\\HKEY_LOCAL_MACHINE\\SOFTWARE\\Classes\\mailto\\shell\\open\\command' + registry value: 'drive:\\path\\gnudoitw.exe \"(mew-url-mailto \"%%1\")\"'" + (interactive + (list (read-from-minibuffer "Mew mailto: "))) + (when (or (not (boundp 'mew-init-p)) (null mew-init-p)) + (save-excursion + (require 'mew) + (mew-init))) + (let ((lst (mew-browse-url-mailto-analysis url))) + (mew-user-agent-compose (nth 0 lst) ;; to + (nth 1 lst) ;; subject + (nth 2 lst) ;; other + nil mew-browse-url-mailto-switch-func))) + +(defun mew-url-mailto-mozex (url) + "Execute mew-user-agent-compose from Mozilla and Firefox with MozEx. + +If use this command, set followings on Mailer form of MozEx. +\"/path/gnudoit (mew-url-mailto-mozex \"%r\")\" +or +\"/path/emacseval (mew-url-mailto-mozex \"%r\")\" + +`emacseval' is a shell script like this, +----cut here---- +#!/bin/sh +/usr/local/bin/emacsclient --eval \"`echo $*`\" +----cut here----" + (interactive) + (when (or (not (boundp 'mew-init-p)) (null mew-init-p)) + (save-excursion + (require 'mew) + (mew-init))) + (let ((lst (mew-browse-url-mailto-analysis url 'mozex))) + (mew-user-agent-compose (nth 0 lst) ;; to + (nth 1 lst) ;; subject + (nth 2 lst) ;; other + nil mew-browse-url-mailto-switch-func))) + +;; return '(to subject other)" +(defun mew-browse-url-mailto-analysis (url &optional mozex) + (let (to subject other) + (while (string-match "[ \t]+" url) + (setq url (concat (substring url 0 (match-beginning 0)) + (substring url (match-end 0))))) + (if (string-match "^mailto:" url) + (setq url (mew-browse-url-mailto-decamp (substring url (match-end 0)))) + (setq url (mew-browse-url-mailto-decamp url))) + (when (string-match "^\\([^?]+\\)" url) + (setq to (mew-browse-url-mailto-hex-to-string + (substring url (match-beginning 1) (match-end 1)))) + (setq url (substring url (match-end 0)))) + (while (string-match "^[?&]\\([^=]+\\)=\\([^&]*\\)" url) + (let ((hname (substring url (match-beginning 1) (match-end 1))) + (hvalue (mew-browse-url-mailto-hex-to-string + (substring url (match-beginning 2) (match-end 2))))) + (setq url (substring url (match-end 0))) + (when mozex + (setq hname (mew-browse-url-mailto-hex-to-string hname)) + (while (string-match "[ \t\n]+" hname) + (setq hname (replace-match "" nil nil hname))) + (when (string-match "[ \t\n]+$" hvalue) + (setq hvalue (replace-match "" nil nil hvalue)))) + (cond + ((string-match "^to$" hname) + (if to + (setq to (concat to ", " hvalue)) + (setq to hvalue))) + ((string-match "^subject$" hname) + (setq subject hvalue)) + (t + (setq other (cons (cons (capitalize hname) hvalue) other)))))) + `(,to ,subject ,other))) + +(defun mew-browse-url-mailto-decamp (str) + (save-match-data + (while (string-match "&" str) + (setq str (concat (substring str 0 (match-beginning 0)) + "&" + (substring str (match-end 0))))) + str)) + +(defun mew-browse-url-mailto-hex-to-string (str) + (save-match-data + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (let ((doit t) char cs) + (while (re-search-forward "%\\([0-9a-fA-F][0-9a-fA-F]\\)" nil t) + (setq char (mew-browse-url-mailto-2hexs-to-int + (buffer-substring (match-beginning 1) (match-end 1)))) + (delete-region (match-beginning 0) (match-end 0)) + (insert char)) + (setq cs (mew-charset-to-cs + (mew-charset-guess-region (point-min) (point-max)))) + (when (or (not cs) + (eq cs mew-cs-unknown)) + (setq cs mew-cs-autoconv)) + (when (and (eq cs 'utf-8) + (not mew-internal-utf-8p) + (not (featurep 'un-define))) + (condition-case nil + (require 'un-define) + (file-error + (setq doit nil) + (delete-region (point-min) (point-max)) + (insert "Install Mule-UCS for UTF-8.\n")))) + (when doit + (mew-set-buffer-multibyte nil) + (decode-coding-region (point-min) (point-max) cs) + (mew-set-buffer-multibyte t)) + (buffer-string))))) + +(defun mew-browse-url-mailto-2hexs-to-int (hex) + (+ (* 16 (mew-hexchar-to-int (aref hex 0))) + (mew-hexchar-to-int (aref hex 1)))) + +(provide 'mew-browse) + +;;; Copyright Notice: + +;; Copyright (C) 1999-2004 Mew developing team. +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. Neither the name of the team nor the names of its contributors +;; may be used to endorse or promote products derived from this software +;; without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; mew-browse.el ends here diff -urN mew.orig/contrib/mew-caesar.el mew/contrib/mew-caesar.el --- mew.orig/contrib/mew-caesar.el 1970-01-01 09:00:00.000000000 +0900 +++ mew/contrib/mew-caesar.el 2011-06-15 00:20:15.000000000 +0900 @@ -0,0 +1,242 @@ +;; -*- emacs-lisp -*- +;; +;; mew-caesar.el --- Caesar encrypt/decrypt assistant package for Mew. +;; +;; Author: Hideyuki SHIRAI +;; Created: <02/07/1998> +;; +;; To use mew-caesar.el, install (tm|SEMI) package or "nkf" +;; , and put the following codes in your .emacs. +;; +;; (add-hook 'mew-init-hook +;; (lambda () +;; (require 'mew-caesar))) +;; + +(eval-when-compile + (require 'mew)) + +(defconst mew-caesar-version "mew-caesar.el 0.21") + +(defvar mew-caesar-ext-prog + (let (extprog) + (cond + ((or (memq system-type '(OS/2 emx)) + (eq system-type 'windows-nt)) + (cond + ((setq extprog (mew-which "nkf.exe" exec-path)) + extprog) + ((setq extprog (mew-which "nkf32.exe" exec-path)) + extprog) + (t nil))) + (t (setq extprog (mew-which "nkf" exec-path)) + extprog))) + "mew-caesar external program. + Usually, auto searched \"nkf\", \"nkf.exe\" or \"nkf32.exe\"." + ) + +(defvar mew-caesar-ext-prog-arg '("-r")) + +(defvar mew-caesar-function + (cond + ((or (featurep 'mule-caesar) + (locate-library "mule-caesar")) + (require 'mule-caesar) + 'semi) + ((or (featurep 'tm-def) + (locate-library "tm-def")) + (require 'tm-def) + 'tm) + (mew-caesar-ext-prog + 'ext) + (t + (message "mew-caesar: program is not found") + nil)) + "mew-caesar function select. + Usually auto selected, which + 'semi(mule-caesar), 'tm(tm:caesar-region) or 'ext(mew-caesar-ext-prog)." + ) + +(defvar mew-caesar-prog-xrot '(mew-caesar-mime-text/x-rot () nil)) +(defconst mew-caesar-ct-rot13 "Text/X-Rot13-47-48") +(defconst mew-caesar-rot13-suffix ".rot") + +(define-key mew-summary-mode-map "\C-cr" 'mew-caesar-summary-insert-xrot) +(define-key mew-draft-attach-map "R" 'mew-caesar-attach-find-new-xrot) + +(setq mew-mime-content-type + (append + '(("text/x-rot13-47-48" "\\.rot$" nil mew-caesar-prog-xrot mew-icon-text) + ("text/x-rot13.*" "\\.rot$" nil mew-caesar-prog-xrot mew-icon-text)) + mew-mime-content-type)) + +(defun mew-caesar-mime-text/x-rot (cache beg end &optional params execute) + (if (> end beg) + (save-excursion + (set-buffer (mew-buffer-message)) + (let ((buffer-read-only nil)) + (insert " # # ###### ####### ####### # #####\n" + " # # # # # # # ## # #\n" + " # # # # # # # # # #\n" + " # ##### ###### # # # # #####\n" + " # # # # # # # # #\n" + " # # # # # # # # # #\n" + " # # # # ####### # ##### #####\n" + "\n") + (insert "To save this part, type " + (substitute-command-keys + "\\\\[mew-summary-save].") + "\nTo display this part in Message mode, type " + (substitute-command-keys + "\\\\[mew-caesar-summary-insert-xrot].")) + (insert "\n\n-------------------- Original \"X-ROT13\" follows --------------------\n") + (insert-buffer-substring cache beg end) + )))) + +(defun mew-caesar-summary-insert-xrot () + (interactive) + (mew-summary-part + (let* ((fld (mew-current-get-fld (mew-frame-id))) + (msg (mew-current-get-msg (mew-frame-id))) + (part (mew-syntax-nums)) + (cache (mew-cache-hit fld msg 'must-hit)) + (syntax (mew-cache-decode-syntax cache)) + (stx (mew-syntax-get-entry syntax part)) + (beg (mew-syntax-get-begin stx)) + (end (mew-syntax-get-end stx)) + (win (selected-window))) + (unwind-protect + (progn + (mew-summary-toggle-disp-msg 'on) + (mew-window-configure 'message) + (set-buffer (mew-buffer-message)) + (mew-elet + (mew-summary-display-preamble) + (insert-buffer-substring cache beg end) + (mew-caesar-whole-buffer) + ;; (goto-char (point-min)) + (mew-summary-display-postscript))) + (select-window win))))) + +(defun mew-caesar-attach-find-new-xrot () + "Open a new Caesar encrypt file into a buffer on \".\" in attachments." + (interactive) + (if (not (mew-attach-not-line012-1)) + (message "Cannot find a new file here") + (let* ((nums (mew-syntax-nums)) + (subdir (mew-attach-expand-path mew-encode-syntax nums)) + (attachdir (mew-attachdir)) + file filepath) + ;; attachdir / {subdir/} dir + (if (not (equal subdir "")) + (setq attachdir (expand-file-name subdir attachdir))) + ;; attachdir / file + (setq filepath (mew-random-filename attachdir 1 nil mew-caesar-rot13-suffix)) + (if (null filepath) + (message "Could not make a text file, sorry") + (setq file (file-name-nondirectory filepath)) + (setq mew-encode-syntax + (mew-syntax-insert-entry + mew-encode-syntax + nums + (mew-encode-syntax-single file (list mew-caesar-ct-rot13)))) + (mew-encode-syntax-print mew-encode-syntax) + ;; + (find-file filepath) + ;; buffer switched + (setq mode-name "X-Rot13") + (setq mode-line-buffer-identification mew-mode-line-id) + (local-set-key "\C-c\C-q" 'mew-kill-buffer) + (local-set-key "\C-cr" 'mew-caesar-whole-buffer) + (local-set-key "\C-c\C-s" 'mew-caesar-save-exit) + (insert " # # ###### ####### ####### # #####\n" + " # # # # # # # ## # #\n" + " # # # # # # # # # #\n" + " # ##### ###### # # # # #####\n" + " # # # # # # # # #\n" + " # # # # # # # # # #\n" + " # # # # ####### # ##### #####\n") + (insert "\n define-key \"\\C-cr\" -> mew-caesar-whole-buffer.") + (insert "\n define-key \"\\C-c\\C-s\" -> mew-caesar-save-exit.") + (insert "\n\n Press any key to start editting.") + (read-char-exclusive) + (delete-region (point-min) (point-max)) + (run-hooks 'mew-caesar-xrot-mode-hook) + )))) + +(defun mew-caesar-save-exit () + "Caesar encrypt/decrypt at whole buffer, save and exit." + (interactive) + (mew-caesar-whole-buffer) + (if (y-or-n-p (format "Save & Exit ?")) + (progn + (save-buffer) + (kill-buffer (current-buffer))) + (mew-caesar-whole-buffer))) + +(defun mew-caesar-whole-buffer () + "Caesar encrypt/decrypt at whole buffer." + (interactive) + (mew-caesar-region (point-min) (point-max))) + +(defun mew-caesar-region (min max) + "Caesar encrypt/decrypt in region." + (interactive "r") + (save-excursion + (cond + ((eq mew-caesar-function 'semi) + (mule-caesar-region min max)) + ((eq mew-caesar-function 'tm) + (progn + (goto-char min) + (push-mark (point) nil t) + (goto-char max) + (tm:caesar-region))) + ((and (eq mew-caesar-function 'ext) + mew-caesar-ext-prog mew-caesar-ext-prog-arg) + (save-excursion + (mew-piolet + mew-cs-autoconv mew-cs-m17n + (apply (function call-process-region) + min max + mew-caesar-ext-prog + t t nil + mew-caesar-ext-prog-arg)))) + (t + (message "mew-caesar: program is not found"))) + )) + +(provide 'mew-caesar) + +;;; Copyright Notice: + +;; Copyright (C) 1998-2000 Hideyuki SHIRAI +;; Copyright (C) 1994-2000 Mew developing team. +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. Neither the name of the team nor the names of its contributors +;; may be used to endorse or promote products derived from this software +;; without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; mew-caesar.el ends here diff -urN mew.orig/contrib/mew-edebug.el mew/contrib/mew-edebug.el --- mew.orig/contrib/mew-edebug.el 1970-01-01 09:00:00.000000000 +0900 +++ mew/contrib/mew-edebug.el 2011-06-20 01:46:27.000000000 +0900 @@ -0,0 +1,145 @@ +;; mew-edebug.el --- Help for using edebug for macros in Mew + +;; Author: Sen Nagata +;; Created: Nov 11, 2001 +;; Version: 0.3 + +;; Set-up: +;; +;; Put this file somewhere in your `load-path' and the following in +;; your .emacs: +;; +;; (add-hook 'mew-init-hook +;; '(lambda () +;; (require 'mew-edebug))) +;; +;; Upon instrumenting a function with `edebug-defun', +;; `mew-edebug-macro-init' will be run to instrument Mew macros. + +;; Issues: +;; +;; I've tested many of the macros below with edebug. Although most +;; appear to work, I experienced problems with some +;; (e.g. `mew-time-rfc-*'). I don't know what the problem is yet, but +;; my current suspicion is that it has something to do with +;; `defsubst'. + +;;; Code: + +(require 'mew) + +(defvar mew-macro-names + '( + mew-header-encode-cond + mew-header-encode-cond2 + mew-complete-proto-folder + mew-decode-narrow-to-header + mew-draft-privacy-switch + mew-summary-header-mode + mew-no-warning-defvar + mew-no-warning-defun + mew-ntake + mew-add-first + mew-addq + mew-insert-after + mew-replace-with + mew-remove-entry + mew-folder-insert + mew-folder-delete + mew-elet + mew-filter + mew-time-rfc-day + mew-time-rfc-mon + mew-time-rfc-year + mew-time-rfc-hour + mew-time-rfc-min + mew-time-rfc-sec + mew-time-rfc-tmzn + mew-rendezvous + mew-defstruct + mew-defstruct-constructor + mew-defstruct-s/getter + mew-addrstr-parse-syntax-list-check-depth + mew-mark-alist-set + mew-mode-input-file-name + mew-mode-input-directory-name + mew-plet + mew-piolet + mew-flet + mew-frwlet + mew-alet + mew-passwd-rendezvous + mew-dolist-eob + mew-pick-lex-cut + mew-summary-refilable + mew-msgid-check + mew-summary-msg-or-part + mew-summary-msg + mew-summary-part + mew-summary-multi-msgs + mew-summary-only + mew-virtual-only + mew-thread-only + mew-pickable + mew-summary-not-in-queue + mew-summary-not-in-draft + mew-summary-not-in-nntp + mew-summary-local-or-imap + mew-summary-local-only + mew-summary-with-mewl + mew-summary-prepare-draft + mew-setface + mew-setface-bold + mew-defface + mew-defface-bold + )) + +(defun mew-edebug-macro-init () + "Call `def-edebug-spec' for each macro in `mew-macro-names'. + +This function should be invoked before instrumenting a function for +use with edebug." + (interactive) + (let ((macro-names mew-macro-names)) + (while macro-names + (eval `(def-edebug-spec ,(car macro-names) t)) + (setq macro-names (cdr macro-names))))) + +;; instrument Mew macros when edebug is used +(add-hook 'edebug-setup-hook + '(lambda () + (mew-edebug-macro-init))) + +(provide 'mew-edebug) + +;;; Copyright Notice: + +;; Copyright (C) 2001 Mew developing team. +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. Neither the name of the team nor the names of its contributors +;; may be used to endorse or promote products derived from this software +;; without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; mew-edebug.el ends here diff -urN mew.orig/contrib/mew-fancy-summary.el mew/contrib/mew-fancy-summary.el --- mew.orig/contrib/mew-fancy-summary.el 1970-01-01 09:00:00.000000000 +0900 +++ mew/contrib/mew-fancy-summary.el 2011-06-15 00:20:15.000000000 +0900 @@ -0,0 +1,565 @@ +;;; mew-fancy-summary.el --- Fontify Mew summary buffer +;; +;; Author: Shun-ichi TAHARA +;; Hideyuki SHIRAI +;; +;; Time-stamp: <03/13/2002 20:45 shirai> + +;;; Commentary: +;; +;; HOW TO USE +;; +;; 1. Set some customize variables and faces as you like. +;; +;; 2. Require this file in your init file of Emacsen. +;; +;; (add-hook 'mew-init-hook (lambda () (require 'mew-fancy-summary))) +;; +;; 3. BE SURE TO USE jit-lock, lazy-shot or lazy-lock. +;; +;; ;;; common setting +;; (require 'font-lock) +;; ;; (global-font-lock-mode t) ;; as you like. +;; +;; ;;; jit-lock-mode (for Emacs-21) +;; (setq font-lock-support-mode 'jit-lock-mode) ;; system default value. +;; +;; ;;; lazy-shot-mode (for XEmacs) +;; (require 'font-lock) +;; (setq font-lock-support-mode 'lazy-shot-mode) +;; (setq lazy-shot-verbose nil) +;; (setq lazy-shot-stealth-verbose nil) +;; +;; ;;; lazy-lock-mode (for All Emacsen) +;; (require 'font-lock) +;; (setq font-lock-support-mode 'lazy-lock-mode) +;; (when (featurep 'xemacs) +;; (setq lazy-lock-minimum-size 0)) +;; +;; 4. If you use 'jit-lock-mode' and feel 'scan is too slow' +;; , please put bellow code to your init file. +;; +;; (add-hook 'mew-init-hook +;; (lambda () +;; (defvar mew-fancy-disable nil) +;; (make-variable-buffer-local 'mew-fancy-disable) +;; (defadvice mew-scan (before fancy-disable activate) +;; (setq mew-fancy-disable t)) +;; (defadvice mew-scan-filter (before fancy-disable activate) +;; (when (and mew-fancy-disable font-lock-mode) +;; (setq mew-fancy-disable nil) +;; (font-lock-mode -1))) +;; )) +;; +;; BUGS +;; +;; 1. If you choice 'lazy-lock-mode', mew-summary-cook-folders() becomes +;; too slow. +;; + +;;; Code: + +(eval-when-compile (require 'mew)) +(defconst mew-fancy-summary-version "mew-fancy-summary 0.23") + +;;; User-customizable variables + +(defcustom mew-fancy-summary-face-spec + '((num . mew-fancy-summary-face-marginal) + (size . mew-fancy-summary-face-marginal) + (type . mew-fancy-summary-face-type) + (from . "From:") + (subj . "Subject:") + (date . "Date:") + (year . "Date:") + (time . "Date:")) + "*Alist of face specs for fancy-summary mode, corresponding to +scan-form entries. Each entry consists of a pair of symbol or string +and face, header name or function. + +The symbol is what can be set in scan-form, including user-extended +entry. + +If you want to highlight the raw string in 'mew-scan-form', put the +string and the corresponding face (or another possible) in this alist. +Also define the face, if needed. + +The face and the function are both set as a symbol in cdr of each +entry. As a special case, you can specify 'nil' not to highlight the +field. + +If the symbol is a function name, the function is called with an +integer argument indicating the width of the field (or 0 means +unlimited) and with the pointer pointing the top of the field to be +highlighted. In the function, you can fontify it as you like, and no +return values are needed (even the cursor position need not be cared). + +The string in cdr of the entry indicates a header name, and a face is +decided by 'mew-field-spec' with the header name." + :group 'mew-highlight + :type '(repeat (cons (choice symbol string) (choice face string function)))) + +(defcustom mew-fancy-summary-extended-face-spec + '((truncated . mew-fancy-summary-face-truncated) + (thread . mew-fancy-summary-face-marginal) + (special . mew-fancy-summary-face-special) + (ml . mew-fancy-summary-face-tag) + (attach . mew-fancy-summary-face-marginal) + (to . "To:")) + "*Alist of face specs for fancy-summary mode, not corresponding to +scan-form entries. Each entry consists of a pair of symbol and face, +header name or function. + +Symbol is one of those: 'truncated' for 'T' mark in the 'type' field +in scan-form, 'thread' for a thread indent, 'special' for the special +person (see also 'mew-fancy-summary-special-*'), 'ml' for a subject +prefix of ML (see also 'mew-fancy-summary-ml-regex'), and 'attach' for +a attachment line. + +For cdr of each element, see 'mew-fancy-summary-face-spec'." + :group 'mew-highlight + :type '(repeat (cons (choice symbol string) (choice face string function)))) + +(defcustom mew-fancy-summary-special-persons nil + "*List of the 'special' persons. + +If the From: header matches a member of this list, 'special' entry of +'mew-fancy-summary-extended-face-spec' is used for highlighting 'from' +part of scan-form." + :group 'mew-highlight + :type '(repeat string)) + +(defcustom mew-fancy-summary-special-addrbook nil + "*If non-nil, nicknames in the addrbook are treated as 'special' +person." + :group 'mew-highlight + :type 'boolean) + +(defcustom mew-fancy-summary-special-to t + "*If non-nil, 'from' part of scan-form about an entry of the mail +destinated to 'special' person (then displayed To: header) are also +highlighted specially." + :group 'mew-highlight + :type 'boolean) + +(defcustom mew-fancy-summary-ml-regex "[\[(][^])|\n\r]*[\])|]" + "*Regex string as a prefix of the subject of mails posted to ML." + :group 'mew-highlight + :type 'regexp) + +(defcustom mew-fancy-summary-external-highlighting-hook nil + "*Hook called to highlight an abnormal line. + +If the function in the hook highlighted the line successfully, it must +return t, otherwise nil." + :group 'mew-highlight + :type 'hook) + +;;; Faces + +(defface mew-fancy-summary-face-marginal nil + "*Face to highlight the marginal part of Summary buffer." + :group 'mew-highlight) + +(defface mew-fancy-summary-face-type nil + "*Face to highlight 'type' part of Summary buffer (except 'T' mark)." + :group 'mew-highlight) + +(defface mew-fancy-summary-face-truncated nil + "*Face to highlight 'T' mark at 'type' part of Summary buffer." + :group 'mew-highlight) + +(defface mew-fancy-summary-face-special nil + "*Face to highlight the special person in 'from' part of Summary buffer." + :group 'mew-highlight) + +(defface mew-fancy-summary-face-tag nil + "*Face to highlight the tag part of Summary buffer." + :group 'mew-highlight) + +;;; End of user-customizable stuffs + +;;; Internal variables + +(defvar mew-fancy-summary-special-list nil) +(defvar mew-fancy-summary-special-alist nil) + +(defvar mew-fancy-summary-scan-form nil) +(make-variable-buffer-local 'mew-fancy-summary-scan-form) + +(defvar mew-fancy-summary-thread-column nil) +(make-variable-buffer-local 'mew-fancy-summary-thread-column) + +;;; Initialization + +(add-hook 'mew-summary-mode-hook 'mew-fancy-summary-enable) +(add-hook 'mew-virtual-mode-hook 'mew-fancy-summary-enable) +(add-hook 'mew-thread-display-hook 'mew-fancy-summary-thread-enable) +(add-hook 'mew-pop-sentinel-hook 'mew-fancy-summary-block) +(add-hook 'mew-scan-sentinel-hook 'mew-fancy-summary-block) + +(setq mew-use-highlight-mark nil) ; Hilight mark by itself, not by Mew + +(defalias 'mew-summary-cook-region 'mew-fancy-summary-make-invisible-region) +(defalias 'mew-highlight-mark-line 'mew-fancy-summary-mark-line) +(defalias 'mew-highlight-unmark-line 'mew-fancy-summary-mark-line) + +;;; Setup + +(defadvice mew-addrbook-setup (after hl-setup activate) + "Setup fancy-summary when starting up Mew or executing \"Z\"." + (mew-fancy-summary-special-setup)) + +(defun mew-fancy-summary-special-setup () + (setq mew-fancy-summary-special-list mew-fancy-summary-special-persons) + (when mew-fancy-summary-special-addrbook + (let ((addrbook mew-addrbook-alist) nickname) + (while addrbook + (setq nickname (nth 2 (car addrbook))) + (when (and (stringp nickname) + (not (member nickname mew-fancy-summary-special-list))) + (setq mew-fancy-summary-special-list + (cons nickname mew-fancy-summary-special-list))) + (setq addrbook (cdr addrbook)))))) + +;;; Workarounds about highlighting in Mew + +(defun mew-fancy-summary-remove-invisible () + "Remove the invisible hook in Mew." + (jit-lock-unregister 'mew-summary-cook-region) + (remove-hook 'window-scroll-functions 'mew-summary-cook-window 'local) + (remove-hook 'pre-idle-hook 'mew-summary-cook-window)) + +(defun mew-fancy-summary-make-invisible-region (beg end &optional interrupt) + "Faster invisible function for summary with many text properties." + (when (and (memq major-mode + '(mew-summary-mode mew-virtual-mode mew-refile-view-mode)) + mew-summary-buffer-raw) + (let ((inhibit-point-motion-hooks t) ret start) + (catch 'loop + (mew-elet + (save-excursion + (goto-char beg) + (while (and (< (point) end) + (search-forward "\r" end t)) + (setq start (match-beginning 0)) + (unless (get-text-property start 'invisible) + (put-text-property start (line-end-position) 'invisible t)) + (forward-line) + (when (and interrupt (input-pending-p)) + (throw 'loop (setq ret t))))))) + (set-buffer-modified-p nil) + ret))) + +(defun mew-fancy-summary-mark-line (&rest args) + "Highlighting mark and unmark line is done by mew-fancy-summary." + (save-excursion + (mew-fancy-summary-region (point) (point) nil 'strip))) + +;;; Activating fancy summary + +(defun mew-fancy-summary-enable () + "Activate mew-fancy-summary in summary or virtual buffer." + (mew-fancy-summary-remove-invisible) + (unless (mew-thread-p) + (set (make-local-variable 'font-lock-fontify-buffer-function) + 'mew-fancy-summary-buffer) + (when (boundp 'font-lock-function) + (set (make-local-variable 'font-lock-function) + 'mew-fancy-summary-font-lock-function)) + (set (make-local-variable 'font-lock-fontify-region-function) + 'mew-fancy-summary-region) + (setq mew-fancy-summary-scan-form + (mew-get-summary-form (mew-summary-folder-name 'ext))) + (setq mew-fancy-summary-thread-column -1) + (font-lock-mode 1))) + +(defun mew-fancy-summary-font-lock-function (font-lock-mode) + (when font-lock-mode + (add-hook 'after-change-functions 'font-lock-after-change-function t t) + (font-lock-turn-on-thing-lock)) + (unless font-lock-mode + (remove-hook 'after-change-functions 'font-lock-after-change-function t) + (font-lock-unfontify-buffer) + (font-lock-turn-off-thing-lock))) + +(defun mew-fancy-summary-thread-enable () + "Activate mew-fancy-summary in thread buffer." + (when (mew-thread-p) + (mew-fancy-summary-remove-invisible) + (setq mew-fancy-summary-scan-form + (mew-get-summary-form (substring (mew-summary-folder-name 'ext) 1))) + (setq mew-fancy-summary-thread-column (mew-vinfo-get-column)) + (when (boundp 'font-lock-function) + (set (make-local-variable 'font-lock-function) + 'mew-fancy-summary-font-lock-function)) + (set (make-local-variable 'font-lock-fontify-buffer-function) + 'mew-fancy-summary-buffer) + (set (make-local-variable 'font-lock-fontify-region-function) + 'mew-fancy-summary-region) + (font-lock-mode 1))) + +;;; macros + +(defmacro mew-fancy-summary-get-face (key extended) + `(let ((face (cdr (assoc ,key (if ,extended + mew-fancy-summary-extended-face-spec + mew-fancy-summary-face-spec))))) + (if (stringp face) + (or (mew-nspec-valface (mew-nspec-by-key face)) + 'mew-face-header-marginal) + face))) + +(defsubst mew-fancy-summary-special-p (key len) + (when (and mew-fancy-summary-special-list (> (length key) 0)) + (member key (or (cdr (assq len mew-fancy-summary-special-alist)) + (let ((special mew-fancy-summary-special-list) + lst str) + (while special + (setq str (truncate-string-to-width (car special) len)) + (when (string-match "^.+\\( +\\)$" str) + (setq str (substring str 0 (match-beginning 1)))) + (setq lst (cons str lst)) + (setq special (cdr special))) + (setq mew-fancy-summary-special-alist + (cons (cons len lst) mew-fancy-summary-special-alist)) + lst))))) + +;;; Main + +(defun mew-fancy-summary-block () + (font-lock-mode 1)) + +(defun mew-fancy-summary-buffer () + "Highlight summary buffer with font-lock-mode." + (interactive) + (mew-fancy-summary-region (point-min) (point-max))) + +(defun mew-fancy-summary-region (beg end &optional loudly strip) + "Highlight the region of summary buffer with font-lock-mode." + (interactive "r") + (let ((pos (point)) linebeg lineend col numend) + (when (memq major-mode + '(mew-summary-mode mew-virtual-mode mew-refile-view-mode)) + (mew-elet + (setq end (progn (goto-char end) + (forward-line) + (point))) + (setq beg (progn (goto-char beg) + (beginning-of-line) + (point))) + (when strip + (put-text-property beg end 'face nil)) + (mew-fancy-summary-make-invisible-region beg end) + ;; Highlight each line + (while (< (point) end) + (setq linebeg (point)) + (setq col 0) + (cond + ;; unread line + ((and (not (mew-in-decode-syntax-p)) + (setq numend (point-min)) + (eq (char-after) mew-mark-unread)) + (let ((form mew-fancy-summary-scan-form) entry) + (while form + (setq entry (car form)) + (when (= col mew-fancy-summary-thread-column) + (setq col (+ col (mew-fancy-summary-do-highlight 'thread t)))) + (setq col (+ col (mew-fancy-summary-do-highlight entry nil numend))) + (setq form (cdr form)))) + (looking-at "[^\r\n]*") + (setq lineend (match-end 0)) + (put-text-property linebeg (1+ linebeg) 'face 'mew-face-mark-unread)) + ;; Normal line + ((and (not (mew-in-decode-syntax-p)) + (setq numend (point-min)) + (not (looking-at mew-regex-mark))) + (let ((form mew-fancy-summary-scan-form) entry) + (while form + (setq entry (car form)) + (when (= col mew-fancy-summary-thread-column) + (setq col (+ col (mew-fancy-summary-do-highlight 'thread t)))) + (setq col (+ col (mew-fancy-summary-do-highlight entry nil numend))) + (setq form (cdr form)))) + (looking-at "[^\r\n]*") + (setq lineend (match-end 0))) + ;; Marked line + ((and (not (mew-in-decode-syntax-p)) + (looking-at mew-regex-mark)) + (let ((mark (string-to-char (match-string 0)))) + (looking-at "[^\r\n]*") + (setq lineend (match-end 0)) + (put-text-property linebeg lineend + 'face (mew-highlight-mark-get-face mark)))) + ;; Others (usually, expanded multi-part) + (t + (unless (run-hook-with-args-until-success + ;; Highlight thread separator or folder of refile-view + ;; by your custom function + 'mew-fancy-summary-external-highlighting-hook nil) + (setq lineend (progn (end-of-line) (point))) + (put-text-property linebeg lineend + 'face (mew-fancy-summary-get-face 'attach t)) + (when mew-use-highlight-mouse-line + (remove-text-properties linebeg (min (1+ lineend) (point-max)) + '(mouse-face)))))) + (when mew-use-highlight-mouse-line + (put-text-property linebeg lineend + 'mouse-face mew-highlight-mouse-line-face)) + (forward-line))) + (set-buffer-modified-p nil) + (goto-char pos)))) + +;;; +(defun mew-fancy-summary-do-highlight (entry &optional extended numend) + (let ((l 0) (col (current-column)) beg end range face + (spec (mew-fancy-summary-get-spec entry extended))) + (while spec + (setq range (car (car spec))) + (setq face (cdr (car spec))) + (cond + ((eq range 'num) + (if (fboundp face) + (funcall face (- numend (point))) + (put-text-property (point) numend 'face face)) + (setq l (+ l (- numend (point)))) + (goto-char numend) + (setq col (current-column))) + ((stringp range) + (when (looking-at range) + (setq beg (match-beginning 0)) + (setq end (match-end 0)) + (if (fboundp face) + (funcall face range) + (put-text-property beg end 'face face)) + (goto-char end) + (setq l (+ l (- (current-column) col))) + (setq col (current-column)))) + ((> range 0) + (setq col (+ col (- range l))) + (setq beg (point)) + (if (fboundp face) + (funcall face (- range l)) + (move-to-column col) + (put-text-property beg (point) 'face face)) + (setq l range))) + (setq spec (cdr spec))) + l)) + +(defun mew-fancy-summary-get-spec (entry extended) + (let ((range (cond + ((stringp entry) (string-width entry)) + ((listp entry) (abs (car entry))) + (t 1))) + (elem (cond + ((listp entry) (nth 1 entry)) + (t entry))) + face) + (if (= range 0) ; To the tail of line + (setq range "[^\r\n]*[^ \r\n]")) + (setq face (mew-fancy-summary-get-face elem extended)) + (cond + ((eq elem t) ;; thread indent + nil) + ((eq elem 'num) + (list (cons elem face))) + ((eq elem 'type) + (cond + ((looking-at "T") + (list (cons range (mew-fancy-summary-get-face 'truncated t)))) + ((looking-at "[^ ]") + (list (cons range face))) + (t + (list (cons range nil))))) + ((eq elem 'thread) + (let ((indent (get-text-property (point) 'mew-thread-indent))) + (if (or (null indent) (= indent 0)) + nil + (list (cons (string-width + (mew-buffer-substring + (point) + (next-single-property-change (point) 'mew-thread-indent))) + face))))) + ((eq elem 'from) + (let* ((beg (point)) + (entry (mew-buffer-substring + beg + (prog2 + (move-to-column (+ (current-column) range)) + (point) + (goto-char beg)))) + (prelen (and (stringp mew-summary-form-from-me-prefix) + (string-width mew-summary-form-from-me-prefix))) + elen) + (if (string-match "[^\r\n]*[^ \r\n]" entry) + (setq entry (substring entry (match-beginning 0) (match-end 0))) + (setq entry "")) + (setq elen (string-width entry)) + (if (not (and prelen (> prelen 0) + (eq (string-match mew-summary-form-from-me-prefix entry) 0))) + ;; Mail to me + (if (mew-fancy-summary-special-p entry range) + (list (cons elen (mew-fancy-summary-get-face 'special t)) + (cons range nil)) + (list (cons elen face) (cons range nil))) + ;; Mail from me + (setq face (mew-fancy-summary-get-face 'to t)) + (if (and prelen mew-fancy-summary-special-to + (mew-fancy-summary-special-p (substring entry prelen) + (- range prelen))) + (list (cons prelen face) + (cons elen (mew-fancy-summary-get-face 'special t)) + (cons range nil)) + (list (cons elen face) (cons range nil)))))) + ((eq elem 'subj) + (list (cons mew-fancy-summary-ml-regex + (mew-fancy-summary-get-face 'ml t)) + (cons + (if (> mew-fancy-summary-thread-column 0) + (save-excursion + (move-to-column mew-fancy-summary-thread-column) + (- range + (* (mew-thread-get-property (point)) + mew-thread-indent-width))) + range) + face))) + (t + (list (cons range face)))))) + +;;; + +(provide 'mew-fancy-summary) + +;;; Copyright Notice: + +;; Copyright (C) 2001 Shun-ichi TAHARA +;; Copyright (C) 1999-2001 Hideyuki SHIRAI +;; Copyright (C) 1994-2001 Mew developing team. +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. Neither the name of the team nor the names of its contributors +;; may be used to endorse or promote products derived from this software +;; without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; mew-fancy-summary.el ends here diff -urN mew.orig/contrib/mew-nmz-fixer.el mew/contrib/mew-nmz-fixer.el --- mew.orig/contrib/mew-nmz-fixer.el 1970-01-01 09:00:00.000000000 +0900 +++ mew/contrib/mew-nmz-fixer.el 2011-06-15 00:20:15.000000000 +0900 @@ -0,0 +1,138 @@ +;; -*- mode: Emacs-Lisp -*- +;; +;;; mew-nmz-fixer.el +;; +;; Author: Hideyuki SHIRAI +;; Created: 2001-01-14(Sun) +;; +;; nmz-mew-summary-fixer.pl $B$r;H$C$F!"(Bpack $B$d(B sort $B$7$?8e$K(B +;; mew-nmz $B7O(B Namazu index $B$r:G?7$KJ]$A$^$9!#(B +;; +;;; nmz-mew-summary-fixer.pl $B$O(B Rei FURUKAWA $B$5$s(B +;;; $B$,:n@.$7$?(B message $B$H(B index $B$NBP1~99?7(B Program $B$G$9!#(B +;; +;; +;;;; $B;H$$J}(B ($B$^$:(B mew-nmz $B$r;H$($k$h$&$K$7$F$*$-$^$7$g$&(B) +;; (eval-after-load "mew-nmz" '(require 'mew-nmz-fixer)) +;; + +(eval-when-compile + (require 'mew) + (require 'mew-nmz)) + +;;;; $B$3$s$J46$8$G(B key $B$K(B bind $B$9$k$bNI$7!#(B + +(add-hook 'mew-summary-mode-hook + (lambda () + (define-key mew-summary-mode-map "zf" 'mew-nmz-fixer-exec))) + +;; add-hook +(add-hook 'mew-sort-hook 'mew-nmz-fixer-exec) +(add-hook 'mew-pack-hook 'mew-nmz-fixer-exec) + +;; variable +(defvar mew-nmz-prog-fixer "nmz-mew-summary-fixer.pl" + "*nmz-mew-summary-fixer.pl $B$N(B Program $BL>!#(B +Windows $B$N?M$O(B \"nmz-mew-summary-fixer\" $B$N$h$&$K3HD%;R$rL5$/$7$?J}$,9,$;$+$b!#(B") + +(defvar mew-nmz-prog-fixer-args + (if (memq system-type '(OS/2 emx windows-nt)) + '("--windows-drive") '()) + "*nmz-mew-summary-fixer.pl $B$KM?$($k(B option$B!#(B") + +;; internal variable +(defvar mew-nmz-fixer-process nil) +(make-variable-buffer-local 'mew-nmz-fixer-process) + +;; function +(defun mew-nmz-fixer-exec (&optional arg) + "Sort/Pack $B$N8e$G(B \"mew-nmz-summary-fixer\" $B$r5/F0$9$k!#(B +\"Another fixer running.\" $B$H$$$o$l$F:$$C$?$H$-$O!"(B'\\[universal-argument]' $BIU$-$G8F$S$^$7$g$&!#(B" + (interactive "P") + (mew-summary-only + (let* ((interactive-p (interactive-p)) + (fld (if interactive-p + (mew-input-folder (mew-sinfo-get-case) + (mew-summary-folder-name)) + (mew-summary-folder-name))) + (fixer (if (fboundp 'mew-which-exec) + (mew-which-exec mew-nmz-prog-fixer) + (mew-which mew-nmz-prog-fixer exec-path))) + (args mew-nmz-prog-fixer-args) + nmzdir) + (if arg + (progn + (setq mew-nmz-fixer-process nil) + (and interactive-p + (message "Set %s to free" mew-nmz-prog-fixer))) + (if (not (and fld fixer)) + (and interactive-p + (message "Cannot exec %s" mew-nmz-prog-fixer)) + (setq nmzdir (mew-nmz-expand-folder fld)) + (if mew-nmz-fixer-process + (message "Another fixer running") + (if (and + nmzdir + (file-exists-p nmzdir) + (file-directory-p nmzdir) + (file-exists-p (expand-file-name "NMZ.i" nmzdir)) + (file-exists-p (expand-file-name "NMZ.field.message-id" nmzdir)) + (file-exists-p (expand-file-name "NMZ.field.size" nmzdir)) + (file-exists-p (expand-file-name "NMZ.field.date" nmzdir)) + (not (file-name-all-completions "NMZ.lock" nmzdir))) + (progn + (and interactive-p + (message "Exec %s (%s)..." mew-nmz-prog-fixer fld)) + (mew-nmz-timestamp-new fld) + (setq mew-nmz-fixer-process + (apply (function start-process) + "nmz-fixer" (current-buffer) fixer + (append args + (list (mew-expand-folder fld) nmzdir)))) + (set-process-sentinel mew-nmz-fixer-process 'mew-nmz-fixer-sentinel)) + (and interactive-p + (message "Cannot exec %s at %s" mew-nmz-prog-fixer nmzdir))))))))) + +(defun mew-nmz-fixer-sentinel (process event) + (save-excursion + (when (and (get-buffer (process-buffer process)) + (buffer-live-p (process-buffer process))) + (set-buffer (process-buffer process)) + (setq mew-nmz-fixer-process nil) + (mew-nmz-timestamp-rename (buffer-name)) + (message "Exec %s (%s)...done" + mew-nmz-prog-fixer (buffer-name))))) + +(provide 'mew-nmz-fixer) + +;;; Copyright Notice: + +;; Copyright (C) 2001 Mew developing team. +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. Neither the name of the team nor the names of its contributors +;; may be used to endorse or promote products derived from this software +;; without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; mew-nmz-fixer.el ends here diff -urN mew.orig/contrib/mew-nmz.el mew/contrib/mew-nmz.el --- mew.orig/contrib/mew-nmz.el 1970-01-01 09:00:00.000000000 +0900 +++ mew/contrib/mew-nmz.el 2011-06-20 01:46:10.000000000 +0900 @@ -0,0 +1,1686 @@ +;; -*- Mode: Emacs-Lisp -*- +;; +;; mew-nmz.el --- Namazu interfaces for Mew +;; +;; Author: Hideyuki SHIRAI +;; Created: Dec 24, 2004 +;; +;; Put your ~/.mew.el +;; (require 'mew-nmz) +;; (setq mew-search-method 'namazu) +;; + +(require 'mew) + +(eval-when-compile + (condition-case nil + (require 'w3m-namazu) + (error nil))) + +;; Variables +(defconst mew-nmz-version "2010-06-08") + +(defgroup mew-nmz nil + "Namazu support with Mew." + :group 'mew) + +(defcustom mew-nmz-index-path "~/Namazu" + "*Namazu index top directory." + :group 'mew-nmz + :type 'directory) + +(defcustom mew-nmz-index-mail "Mail" + "*Namazu index mail directory name." + :group 'mew-nmz + :type 'string) + +(defcustom mew-nmz-setup-hook nil + "*Hook called on mew-nmz-setup." + :group 'mew-nmz + :type 'hook) + +(defcustom mew-nmz-prog "namazu" + "*Namazu program name." + :group 'mew-nmz + :type 'string) + +(defcustom mew-nmz-prog-args nil + "*Namazu's arguments." + :group 'mew-nmz + :type '(repeat string)) + +(defcustom mew-nmz-prog-mknmz "mknmz" + "*Namazu make index program." + :group 'mew-nmz + :type 'string) + +(defcustom mew-nmz-prog-mknmz-args '("--decode-base64") + "*Mknmz's argument, in addition to \"--no-encode-uri\", \"--mailnews\"." + :group 'mew-nmz + :type '(repeat string)) + +(defcustom mew-nmz-prog-mknmz-include "~/Namazu/mknmz-inc.pl" + "*Include file for mknmz." + :group 'mew-nmz + :type 'file) + +(defcustom mew-nmz-mknmz-skip-folders-regexp + (mapcar 'regexp-quote + (delq nil + `(,mew-draft-folder ,mew-trash-folder ,mew-queue-folder ,mew-attach-folder + ,mew-imap-queue-folder ,mew-imap-trash-folder ,mew-postq-folder + ,@mew-trash-folder-list ,@mew-imap-trash-folder-list + "+schedule"))) + "*Folders regexp to skip the index creating." + :group 'mew-nmz + :type '(repeat regexp)) + +(defcustom mew-nmz-mknmz-use-mode-line t + "*Display indicator of namazu in mode line." + :group 'mew-nmz + :type 'boolean) + +(defcustom mew-nmz-line-id '("Mew(nmz): %7b") + "*A value of mode-line-buffer-identification for Mew summary mode, when mknmzing." + :group 'mew-nmz + :type '(list string)) + +(defcustom mew-nmz-mknmz-timer-interval 0.1 + "*Seconds of interval to execute next mknmz." + :group 'mew-nmz + :type 'number) + +(defcustom mew-nmz-pick-default-field nil + "*Default prefix string to be appeared when inputting a namazu pick pattern. +A good example is \"+from:\"." + :group 'mew-nmz + :type '(choice string (const nil))) + +(defcustom mew-nmz-pick-field-list + '("subject=" "from=" "to=" "newsgroups=" "date=" + "message-id=" "cc=" "in-reply-to=" "references=") + "*A list of key for namazu pick pattern." + :group 'mew-nmz + :type '(repeat string)) + +(defcustom mew-nmz-pick-gather-field-list + `((,mew-from: address "from=" "to=" "cc=") + (,mew-to: address "from=" "to=" "cc=") + (,mew-cc: address "from=" "to=" "cc=") + (,mew-message-id: msgid "message-id=" "in-reply-to=" "references=") + (,mew-in-reply-to: msgid "message-id=" "in-reply-to=" "references=") + (,mew-references: msgid "message-id=" "in-reply-to=" "references=")) + "*A list of completion keyword from message." + :group 'mew-nmz + :type '(repeat (list string + (choice (const address) (const msgid)) + string string string))) + +(defcustom mew-nmz-search-parent-folder `(,mew-inbox-folder) + "*Search folder for parent or child, " + :group 'mew-nmz + :type '(repeat string)) + +(defcustom mew-nmz-db-max 64 + "*Namazu max index. +This value MUST be less then equal `INDEX_MAX' of libnamazu.h." + :group 'mew-nmz + :type 'integer) + +(defcustom mew-nmz-query-max-length 256 + "*Namazu query string max length. + This value MUST be less then equal `QUERY_MAX' of libnamazu.h." + :group 'mew-nmz + :type 'integer) + +(defcustom mew-nmz-mark-pick mew-mark-review + "*Mark for Namazu pick." + :group 'mew-nmz + :type 'character) + +(defcustom mew-nmz-mark-unindexed mew-mark-review + "*Mark for type unindexed messages." + :group 'mew-nmz + :type 'character) + +(defcustom mew-ask-virtual-folder-name nil + "*If *non-nil*, ask a virtual folder name." + :group 'mew-summary + :type 'boolean) + +(defcustom mew-nmz-cache-file-prefix ".mew-nmz-" + "*Prefix of the cache filename. Expand with mew-conf-path when use it." + :group 'mew-nmz + :type 'string) + +(defcustom mew-nmz-mknmz-index-file ".mewmknmz" + "*File name of the input file of mewmknmz. Expand with mew-conf-path when use it." + :group 'mew-nmz + :type 'string) + +(defcustom mew-nmz-input-folders-asterisk t + "*Add \"*\" at the end of input folder name." + :group 'mew-nmz + :type 'boolean) + +(defcustom mew-nmz-prog-gcnmz "gcnmz" + "*Program name for the garbage collection." + :group 'mew-nmz + :type 'string) + +(defcustom mew-nmz-use-gcnmz-folders-regexp `(,(regexp-quote mew-inbox-folder)) + "*Folders regexp to execute gcnmz." + :group 'mew-nmz + :type '(repeat regexp)) + +(defcustom mew-nmz-gcnmz-line-id '("Mew(gcn): %7b") + "*A value of mode-line-buffer-identification for Mew summary mode, when gcnmzing." + :group 'mew-nmz + :type '(list string)) + +(defcustom mew-nmz-prog-rfnmz "rfnmz" + "*Program name for the re-index." + :group 'mew-nmz + :type 'string) + +(defcustom mew-nmz-mknmz-index-file-coding-system + (when (boundp 'default-file-name-coding-system) + default-file-name-coding-system) + "*Coding system of index-file." + :group 'mew-nmz + :type '(coding-system :size 0)) + +;; internal variable, don't modify. +(defvar mew-nmz-gather-header-list nil) +(defvar mew-nmz-indexed-folders nil) + +(defvar mew-nmz-input-folder-hist nil) + +(defvar mew-nmz-mknmz-process nil) +(defvar mew-nmz-mknmz-process-folder nil) +(defvar mew-nmz-mknmz-process-file nil) + +(make-variable-buffer-local 'mew-nmz-mknmz-process) +(make-variable-buffer-local 'mew-nmz-mknmz-process-folder) +(make-variable-buffer-local 'mew-nmz-mknmz-process-file) + +(defconst mew-nmz-namazu-index-alias "_mew-namazu" + "*Alias name for mew-nmz-namazu.") +(defvar mew-nmz-namazu-content-type "message/mew") +(defvar mew-nmz-namazu-pattern nil) +(defvar mew-nmz-namazu-miss-folders nil) + +(defvar mew-nmz-setup-p nil) +(defvar mew-nmz-imap-case-alist nil) +(defvar mew-nmz-nntp-case-alist nil) +(defvar mew-nmz-pop-case-alist nil) +(defvar mew-nmz-fld-index-alist nil) +(defvar mew-nmz-url-fld-alist nil) +(defvar mew-nmz-mknmz-all-folders nil) +(defvar mew-nmz-mknmz-continue-timer nil) + +(defvar mew-nmz-mknmz-lang-alist + '(("Japanese" "ja"))) + +(defvar mew-nmz-cs-index (cond + ((mew-coding-system-p 'euc-japan-unix) + 'euc-japan-unix) + ((mew-coding-system-p 'euc-jp-unix) + 'euc-jp-unix) + (t mew-cs-text-for-write)) + "*Coding system to write 'NMZ.field.uri'.") + +(defconst mew-nmz-result-regex + (concat "^\\(.*\\)" (regexp-quote mew-path-separator) "\\([0-9]+\\)")) + +(defconst mew-nmz-use-drive-letter + (memq system-type '(OS/2 emx windows-nt cygwin))) + +;; Set up +(defvar mew-nmz-search-method `(namazu "Namazu" ,mew-nmz-prog + mew-nmz-search + mew-nmz-search-virtual + mew-nmz-mknmz + mew-nmz-mknmz-all-folders + mew-nmz-pick-canonicalize-pattern)) + +(eval-after-load "mew-search" + `(setq mew-search-switch + (cons mew-nmz-search-method mew-search-switch))) + +;; (define-key mew-summary-mode-map "k" (make-sparse-keymap)) +;; (define-key mew-summary-mode-map "kc" 'mew-summary-search-change-method) +;; (define-key mew-summary-mode-map "k?" 'mew-summary-search) +;; (define-key mew-summary-mode-map "k/" 'mew-summary-selection-by-search) +;; (define-key mew-summary-mode-map "km" 'mew-summary-make-index-folder) +;; (define-key mew-summary-mode-map "kM" 'mew-summary-make-index-all) + +(add-hook 'mew-summary-mode-hook + (lambda () + (define-key mew-summary-mode-map "kg" 'mew-nmz-gcnmz) + (define-key mew-summary-mode-map "ks" 'mew-nmz-mknmz-save-mewmknmz) + (define-key mew-summary-mode-map "kK" 'mew-nmz-mknmz-kill-process) + (define-key mew-summary-mode-map "ku" 'mew-nmz-mark-unindexed) + (define-key mew-summary-mode-map "k^" 'mew-nmz-search-parent) + (define-key mew-summary-mode-map "kp" 'mew-nmz-search-parent) + (define-key mew-summary-mode-map "kn" 'mew-nmz-search-child) + (define-key mew-summary-mode-map "kN" 'mew-nmz-namazu) + (define-key mew-summary-mode-map "kj" 'mew-nmz-jump-message))) + +(add-hook 'mew-message-mode-hook + (lambda () + (define-key mew-message-mode-map "k" (make-sparse-keymap)) + (define-key mew-message-mode-map "kp" 'mew-nmz-search-msgid-at-point) + (define-key mew-message-mode-map "kr" 'mew-nmz-search-msgid-region))) + +(defun mew-nmz-pick-field-list () + (let ((lst (append mew-pick-field-list + mew-nmz-pick-field-list + (mew-nmz-pick-pattern-gather-header)))) + (mew-uniq-list lst))) + +(defadvice mew-summary-search (around mew-nmz activate compile) + "Use mew-nmz gather-header." + (if (eq mew-search-method 'namazu) + (let ((mew-pick-field-list (mew-nmz-pick-field-list))) + ad-do-it) + ad-do-it)) + +(defadvice mew-summary-selection-by-search (around mew-nmz activate compile) + "Use mew-nmz gather-header." + (if (eq mew-search-method 'namazu) + (let ((mew-pick-field-list (mew-nmz-pick-field-list))) + ad-do-it) + ad-do-it)) + +(add-hook 'mew-summary-rename-folder-hook 'mew-nmz-folder-index-rename) +(add-hook 'mew-summary-delete-folder-hook 'mew-nmz-folder-index-delete) +(add-hook 'mew-status-update-hook 'mew-nmz-status-update) +(add-hook 'mew-quit-hook 'mew-nmz-cleanup) + +(when (and (featurep 'mw32script) + (fboundp 'define-process-argument-editing)) + ;; Argument setting for mknmz.bat, gcnmz.bat, rfnmz.bat + (let ((progs '("mknmz" "gcnmz" "rfnmz")) + prog) + (while progs + (setq prog (mew-which-exec (car progs))) + (setq progs (cdr progs)) + (when (and prog (string-match "\\.bat$" prog)) + (setq prog (regexp-quote prog)) + ;; (general-process-argument-editing-function + ;; ARGUMENT QUOTING ARGV0ISP &optional EP H2SP QP S2ISP) + (define-process-argument-editing + prog + (lambda (x) (general-process-argument-editing-function x nil nil)) + 'first))))) + +;; macro +(defmacro mew-nmz-imap-directory-file-name (fld case) + `(condition-case nil + (mew-imap-directory-file-name ,fld ,case) + (error ,fld))) + +(defmacro mew-nmz-cache-file-name (part) + `(expand-file-name (concat mew-nmz-cache-file-prefix + (symbol-name ,part) + "-alist") + mew-conf-path)) + +(defmacro mew-nmz-cache-alist-name (part) + `(intern (concat "mew-nmz-" (symbol-name ,part) "-alist"))) + +(defsubst mew-nmz-expand-folder (case:folder) + "Convert case:folder to the directory name of namazu's index." + (let* ((fld (mew-case:folder-folder case:folder)) + (imapp (mew-folder-imapp fld)) + (mew-mail-path (concat (file-name-as-directory mew-nmz-index-path) + mew-nmz-index-mail)) + (nmzdir (directory-file-name (mew-expand-folder case:folder)))) + (if (not imapp) + nmzdir + (while (string-match "[][]" nmzdir) + (setq nmzdir (concat (substring nmzdir 0 (match-beginning 0)) + "%%" + (substring nmzdir (match-end 0))))) + nmzdir))) + +(defsubst mew-nmz-case-folder-normalize (case:folder) + (let ((case (mew-case:folder-case case:folder)) + (fld (mew-case:folder-folder case:folder)) + (newcase "")) + (setq fld (directory-file-name fld)) + (when (mew-folder-imapp fld) + (setq fld (mew-nmz-imap-directory-file-name fld case))) + (cond + ((or (string= fld "") + (string= fld "*") + (mew-folder-imapp fld)) + (setq newcase (or (cdr (assoc case mew-nmz-imap-case-alist)) ""))) + ((mew-folder-popp fld) + (setq newcase (or (cdr (assoc case mew-nmz-pop-case-alist)) ""))) + ((mew-folder-nntpp fld) + (setq newcase (or (cdr (assoc case mew-nmz-nntp-case-alist)) "")))) + (if (string= newcase "") + fld + (concat newcase ":" fld)))) + +(defsubst mew-nmz-case-normalize (case:folder) + (let ((case (mew-case:folder-case case:folder)) + (fld (mew-case:folder-folder case:folder)) + (newcase "")) + (cond + ((or (string= fld "") + (string= fld "*") + (mew-folder-imapp fld)) + (setq newcase (or (cdr (assoc case mew-nmz-imap-case-alist)) ""))) + ((mew-folder-popp fld) + (setq newcase (or (cdr (assoc case mew-nmz-pop-case-alist)) ""))) + ((mew-folder-nntpp fld) + (setq newcase (or (cdr (assoc case mew-nmz-nntp-case-alist)) "")))) + newcase)) + +(defsubst mew-nmz-folder-to-nmzdir (folder) + (mew-nmz-setup) + (cdr (assoc (directory-file-name folder) mew-nmz-fld-index-alist))) + +(defsubst mew-nmz-url-to-folder (url) + (mew-nmz-setup) + (when (and mew-nmz-use-drive-letter + (string-match "^/\\([a-zA-Z]\\)|\\(/.*\\)" url)) + (setq url (concat + (substring url (match-beginning 1) (match-end 1)) + ":" + (substring url (match-beginning 2) (match-end 2))))) + (cdr (assoc (expand-file-name url) mew-nmz-url-fld-alist))) + +(defsubst mew-nmz-indexed-folder-p (fld) + (let ((nmzdir (mew-nmz-expand-folder fld))) + (and nmzdir + (file-directory-p nmzdir) + (file-exists-p (expand-file-name "NMZ.i" nmzdir))))) + +;; Mew interface +(defun mew-nmz-search (pattern folder &rest args) + (mew-nmz-multi-pick + (list (mew-nmz-expand-folder folder)) pattern nil 'single)) + +(defun mew-nmz-search-virtual (pattern flds &rest args) + (mew-nmz-setup) + (let* ((nmzdirs (mew-nmz-flds-to-indexs (or flds (list "*:*")))) + (fldmsgs (mew-nmz-multi-pick nmzdirs pattern nil)) + (file (mew-make-temp-name)) + (rttl 0) + fld) + (with-temp-buffer + (dolist (fldmsg fldmsgs) + (setq fld (car fldmsg)) + (unless (mew-folder-localp fld) + (setq fld (mew-path-to-folder (mew-expand-folder fld)))) + (insert (format "CD:%s\n" fld)) + (dolist (msg (cdr fldmsg)) + (insert msg "\n") + (setq rttl (1+ rttl)))) + (mew-frwlet + mew-cs-text-for-read mew-cs-text-for-write + (write-region (point-min) (point-max) file nil 'no-msg))) + (list file rttl))) + +;; codes +(defun mew-nmz-jump-message () + "Jump to physical folder and message from virtual folder +or jump to virtual folder from physical folder." + (interactive) + (let ((disp (mew-sinfo-get-disp-msg)) + fld msg) + (cond + ((mew-thread-p) + (mew-summary-goto-message) + (setq fld (or (mew-vinfo-get-original-folder) + (mew-vinfo-get-physical-folder))) + (setq msg (mew-summary-message-number))) + ((mew-virtual-p) + (mew-summary-goto-message) + (setq fld (mew-summary-folder-name)) + (setq msg (mew-summary-message-number))) + (t + (setq fld (mew-summary-folder-name)) + (setq msg (mew-summary-message-number)) + (save-excursion + (let ((regex (format "\r %s %s[^0-9]" (regexp-quote fld) msg))) + (setq fld (catch 'detect + (dolist (buf (delq (current-buffer) (buffer-list))) + (set-buffer buf) + (save-excursion + (when (and (mew-virtual-p) + (or (re-search-forward regex nil t) + (re-search-backward regex nil t))) + (throw 'detect (buffer-name buf))))) + nil)))))) + (if (not fld) + (message "Nothing to do") + (mew-nmz-goto-folder-msg fld msg nil disp) + (message "Jump to %s/%s" fld msg)))) + +(defun mew-nmz-mknmz-lang-arg () + (when (boundp 'current-language-environment) + (let* ((env current-language-environment) + (alist mew-nmz-mknmz-lang-alist) + (lang (nth 1 (assoc env alist)))) + (if lang (format "--indexing-lang=%s" lang))))) + +;; "Make Index" functions. +(defun mew-nmz-mknmz (&optional fld all disp) + "Make namazu index for mew-nmz. +If executed with '\\[universal-argument]', make indices without the check of timestamp files. +If executed with '\\[universal-argument] 0', remove indices before make index." + (interactive + (list (directory-file-name + (mew-input-folder (mew-sinfo-get-case) + (or (mew-sinfo-get-folder) mew-inbox-folder))) + nil)) + (save-excursion + (let ((msgenb (or (interactive-p) + (eq this-command 'mew-summary-make-index-folder) + disp)) + (force (and current-prefix-arg + (not (eq current-prefix-arg 0)))) + (remove (eq current-prefix-arg 0)) + (flddir (mew-expand-folder fld)) + (nmzdir (mew-nmz-expand-folder fld)) + (bufname (format "%s*Mew* mknmz*%s" + (if (memq mew-debug '(namazu t)) "" " ") + fld)) + (args mew-nmz-prog-mknmz-args) + (procname (concat mew-nmz-prog-mknmz "-" fld)) + (procname2 (concat mew-nmz-prog-gcnmz "-" fld)) + (incfile (and mew-nmz-prog-mknmz-include + (expand-file-name mew-nmz-prog-mknmz-include))) + (tmpfile (mew-make-temp-name)) + flist continue) + (unless fld + (setq fld (directory-file-name + (mew-input-folder (mew-sinfo-get-case) (mew-sinfo-get-folder))))) + (cond + ((not (mew-which-exec mew-nmz-prog-mknmz)) + (message "Please install mknmz")) + ((or (mew-folder-virtualp fld) (mew-nmz-skip-folder-p fld)) + (and msgenb (message "Cannot make namazu index in %s" fld)) + (setq continue t)) + ((or (get-process procname) (get-process procname2)) + (and msgenb (message "Detect running mknmz/gcnmz process in %s" fld)) + (setq continue t)) + ((and (not remove) (not force) (mew-nmz-index-new-p fld)) + (and msgenb (message "%s has a newer namazu index" fld)) + (setq continue t)) + ((and (not remove) (file-exists-p (expand-file-name "NMZ.lock2" nmzdir))) + (message "Something error in %s's index" fld) + (setq continue t)) + ((not (setq flist (mew-dir-messages (file-chase-links flddir) + nil 'full))) + (and msgenb (message "%s has no message" fld)) + (mew-nmz-index-delete nmzdir) + (setq continue t)) + ((and flddir nmzdir (file-directory-p flddir)) + (with-temp-buffer + (dolist (file flist) + (insert file "\n")) + (mew-frwlet + mew-cs-autoconv mew-cs-text-for-write + (write-region (point-min) (point-max) tmpfile nil 'nomsg))) + (setq args (delq nil + (append args + (list "--no-encode-uri" + ;; "--mailnews" + (mew-nmz-mknmz-lang-arg) + (when (and incfile (file-exists-p incfile)) + (format "--include=%s" incfile)) + (format "--target-list=%s" tmpfile) + ;; (format "--exclude=%s" + ;; (expand-file-name ".+/" flddir)) + (format "--output-dir=%s" nmzdir))))) + ;; flddir)))) + (unless (file-directory-p nmzdir) + (mew-make-directory nmzdir)) + (when remove + (mew-nmz-index-delete nmzdir)) + (set-buffer (get-buffer-create bufname)) + (erase-buffer) + ;; folder set + (and msgenb (message "Namazu indexing for %s..." fld)) + (insert (format "mew-mknmz-prog: %s\nmew-mknmz-args: %s\n" + (mew-which-exec mew-nmz-prog-mknmz) + (mapconcat 'identity args " "))) + (mew-nmz-timestamp-new fld) + (mew-piolet + mew-cs-autoconv mew-cs-text-for-write + (setq mew-nmz-mknmz-process + (apply (function start-process) + procname (current-buffer) mew-nmz-prog-mknmz args))) + (setq mew-nmz-mknmz-process-folder fld) + (setq mew-nmz-mknmz-process-file tmpfile) + (set-process-sentinel mew-nmz-mknmz-process 'mew-nmz-mknmz-sentinel) + (when (and mew-nmz-mknmz-use-mode-line + fld (get-buffer fld) (buffer-name (get-buffer fld))) + (save-excursion + (set-buffer (get-buffer fld)) + (setq mode-line-buffer-identification mew-nmz-line-id) + (set-buffer-modified-p nil))))) + (when (and continue all mew-nmz-mknmz-all-folders) + (mew-nmz-mknmz-continue-with-timer))))) + +(defun mew-nmz-mknmz-continue-with-timer () + (unless mew-nmz-mknmz-continue-timer + (setq mew-nmz-mknmz-continue-timer + (run-at-time mew-nmz-mknmz-timer-interval nil 'mew-nmz-mknmz-continue)))) + +(defun mew-nmz-mknmz-continue () + (when mew-nmz-mknmz-continue-timer + (cancel-timer mew-nmz-mknmz-continue-timer) + (setq mew-nmz-mknmz-continue-timer nil)) + (setq mew-nmz-mknmz-all-folders (cdr mew-nmz-mknmz-all-folders)) + (if mew-nmz-mknmz-all-folders + (mew-nmz-mknmz (car mew-nmz-mknmz-all-folders) 'all) + (ding) + (message "All mknmz done"))) + +(defun mew-nmz-mknmz-sentinel (process event) + (save-excursion + (set-buffer (process-buffer process)) + (let* ((fld mew-nmz-mknmz-process-folder) + (nmzdir (mew-nmz-expand-folder fld)) + msg success) + (when (and (file-exists-p mew-nmz-mknmz-process-file) + (file-writable-p mew-nmz-mknmz-process-file)) + (delete-file mew-nmz-mknmz-process-file)) + (goto-char (point-min)) + (if (search-forward-regexp "^ERROR:.*$" nil t) + (progn + (setq msg (format "Mew mknmz (%s)...%s" fld (match-string 0))) + (condition-case nil + (progn + (mew-nmz-index-delete nmzdir 'tmpfiles) + (delete-file (expand-file-name "NMZ.lock2" nmzdir)) + (delete-file (expand-file-name "NMZ.stamp.new" nmzdir))) + (error nil))) + (setq success t) + (mew-nmz-timestamp-rename fld) + (setq msg (format "Namazu indexing %s...done" fld)) + (when mew-nmz-setup-p + (setq fld (mew-nmz-case-folder-normalize fld)) + (unless (mew-nmz-folder-to-nmzdir fld) + (setq mew-nmz-fld-index-alist + (cons (cons fld nmzdir) mew-nmz-fld-index-alist)) + (setq mew-nmz-url-fld-alist + (cons (cons (mew-expand-folder fld) fld) + mew-nmz-url-fld-alist)) + (mew-nmz-cache-save)))) + (setq mew-nmz-mknmz-process nil) + (setq mew-nmz-mknmz-process-folder nil) + (when (and mew-nmz-mknmz-use-mode-line + fld (get-buffer fld) (buffer-name (get-buffer fld))) + (save-excursion + (set-buffer (get-buffer fld)) + (setq mode-line-buffer-identification + (if (fboundp 'mew-mode-line-id) + (mew-mode-line-id) + mew-mode-line-id)) + (set-buffer-modified-p nil))) + (set-buffer-modified-p nil) + (unless (memq mew-debug '(namazu t)) + (kill-buffer (current-buffer))) + (message "%s" msg) + (when (and success (mew-nmz-gcnmz-folder-p fld)) + (mew-nmz-gcnmz fld nmzdir)) + (when mew-nmz-mknmz-all-folders + (mew-nmz-mknmz-continue-with-timer))))) + +(defun mew-nmz-gcnmz (&optional fld nmzdir) + "Garbage collection for mew-nmz." + (interactive + (list (directory-file-name + (mew-input-folder (mew-sinfo-get-case) + (or (mew-sinfo-get-folder) mew-inbox-folder))) + nil)) + (unless nmzdir + (setq nmzdir (mew-nmz-expand-folder fld))) + (if (and (mew-which-exec mew-nmz-prog-gcnmz) + (file-directory-p nmzdir) + (file-exists-p (expand-file-name "NMZ.i" nmzdir))) + (let ((buf (get-buffer-create + (format "%s*Mew* gcnmz*%s" + (if (memq mew-debug '(namazu t)) "" " ") + fld))) + (procname (concat mew-nmz-prog-gcnmz "-" fld)) + (args `("--no-backup" ,nmzdir)) + process) + (save-excursion + (set-buffer buf) + (erase-buffer) + (setq mew-nmz-mknmz-process-folder fld) + (message "Mew gcnmz (%s)..." mew-nmz-mknmz-process-folder) + (insert (format "mew-gcnmz-prog: %s\nmew-gcnmz-args: %s\n" + (mew-which-exec mew-nmz-prog-gcnmz) + (mapconcat 'identity args " "))) + (setq process + (apply (function start-process) + procname (current-buffer) mew-nmz-prog-gcnmz args)) + (set-process-sentinel process 'mew-nmz-gcnmz-sentinel) + (when (and mew-nmz-mknmz-use-mode-line + fld (get-buffer fld) (buffer-name (get-buffer fld))) + (save-excursion + (set-buffer (get-buffer fld)) + (setq mode-line-buffer-identification mew-nmz-gcnmz-line-id) + (set-buffer-modified-p nil))))) + (when (interactive-p) + (message "gcnmz cannot run on %s" fld)))) + +(defun mew-nmz-gcnmz-sentinel (process event) + (when (buffer-name (process-buffer process)) + (set-buffer (process-buffer process)) + (let ((fld mew-nmz-mknmz-process-folder)) + (if (and fld event (stringp event) (string= event "kill")) + (progn + (message "Mew gcnmz (%s)...kill from user" fld) + (condition-case nil + (mew-nmz-index-delete (mew-nmz-expand-folder fld) 'tmpfiles) + (error nil))) + (message "Mew gcnmz (%s)...done" fld)) + (when (and mew-nmz-mknmz-use-mode-line + fld (get-buffer fld) (buffer-name (get-buffer fld))) + (save-excursion + (set-buffer (get-buffer fld)) + (setq mode-line-buffer-identification + (if (fboundp 'mew-mode-line-id) + (mew-mode-line-id) + mew-mode-line-id)) + (set-buffer-modified-p nil))) + (unless (memq mew-debug '(namazu t)) + (kill-buffer (current-buffer)))))) + +(defun mew-nmz-mknmz-kill-process () + "Kill the all processes of mknmz." + (interactive) + (when mew-nmz-mknmz-continue-timer + (cancel-timer mew-nmz-mknmz-continue-timer) + (setq mew-nmz-mknmz-continue-timer nil)) + (let ((proc-list (process-list)) + (regex1 (concat "^" mew-nmz-prog-mknmz "-")) + (regex2 (concat "^" mew-nmz-prog-gcnmz "-")) + buf kill) + (dolist (process proc-list) + (cond + ((string-match regex1 (process-name process)) + ;; mknmz + (setq buf (process-buffer process)) + (when (buffer-name buf) + (save-excursion + (set-buffer buf) + (set-process-sentinel process 'ignore) + (goto-char (point-max)) + (insert "\nERROR: Kill from user.\n") + (kill-process process) + (mew-nmz-mknmz-sentinel process "kill") + (setq kill t)))) + ((string-match regex2 (process-name process)) + ;; gcnmz + (setq buf (process-buffer process)) + (when (buffer-name buf) + (set-process-sentinel process 'ignore) + (kill-process process) + (mew-nmz-gcnmz-sentinel process "kill") + (setq kill t))))) + (setq mew-nmz-mknmz-all-folders nil) + (when (interactive-p) + (if kill + (message "All process of mknmz killed") + (message "No process of mknmz"))))) + +(defun mew-nmz-mknmz-get-all-folders () + (let ((protos (delq mew-folder-virtual (copy-sequence mew-folder-prefixes))) + (allcases (or mew-config-cases '(""))) + flist cases donecases flds fld dir) + (message "mew-nmz getting all folders...") + (dolist (proto protos) + (setq flds nil) + (setq cases allcases) + (setq donecases nil) + (dolist (case cases) + (if (or (string= case mew-case-default) + (string= case "")) + (setq case (mew-nmz-case-normalize proto)) + (setq case (mew-nmz-case-normalize + (concat case ":" proto)))) + (unless (member case donecases) + (setq donecases (cons case donecases)) + (setq flds + (cond + ((mew-folder-imapp proto) + (mapcar (lambda (x) (car x)) + (mew-imap-folder-alist case))) + ((mew-folder-nntpp proto) + (mapcar (lambda (x) (car x)) + (mew-nntp-folder-alist case))) + ((mew-folder-popp proto) + (mapcar (lambda (x) (car x)) + (mew-pop-folder-alist))) + (t + (mapcar (lambda (x) (car x)) + (mew-local-folder-alist))))) + (setq case (if (string= case "") + "" + (concat case ":"))) + (dolist (fld flds) + (setq fld (concat case fld)) + (setq dir (mew-expand-folder fld)) + (when (and dir + (file-exists-p dir) + (file-directory-p dir) + (file-exists-p (expand-file-name mew-summary-touch-file dir))) + (setq flist (cons (directory-file-name fld) flist))))))) + (prog1 + (setq flist (nreverse flist)) + (with-temp-buffer + (dolist (fld flist) + (unless (mew-nmz-skip-folder-p fld) + (insert (format "%s\t%s\t%s\n" + fld + (mew-expand-folder fld) + (mew-nmz-expand-folder fld)))) + (setq flist (cdr flist))) + (mew-frwlet + mew-cs-text-for-read mew-nmz-mknmz-index-file-coding-system + (write-region (point-min) (point-max) + (expand-file-name mew-nmz-mknmz-index-file mew-conf-path) + nil 'nomsg))) + (message "mew-nmz getting all folders...done")))) + +(defun mew-nmz-mknmz-all-folders (&optional args) + "Make namazu index all folders." + (interactive "P") + (setq args (or args current-prefix-arg)) + (when (or (null mew-nmz-mknmz-all-folders) + (and mew-nmz-mknmz-all-folders + (prog1 + (y-or-n-p "Another mew-nmz-mknmz-all-folders() detect. Kill it? ") + (mew-nmz-mknmz-kill-process)))) + (when (y-or-n-p (format "Make index in all %s? " + (if args "folders" "indexed folders"))) + (let (alist flist) + (if args + (progn + ;; all exist folder + (mew-nmz-cleanup 'remove) + (setq flist (mew-nmz-mknmz-get-all-folders))) + ;; all indexed folder + (mew-nmz-setup) + (setq alist mew-nmz-fld-index-alist) + (while alist + (setq flist (cons (car (car alist)) flist)) + (setq alist (cdr alist)))) + (setq flist (nreverse flist)) + ;; for mew-nmz-mknmz() + (setq current-prefix-arg nil) + (setq mew-nmz-mknmz-all-folders flist) + (when flist + (mew-nmz-mknmz (car flist) 'all)))))) + +(defun mew-nmz-mknmz-save-mewmknmz () + "Save the information for mknmz." + (interactive) + (mew-nmz-cleanup 'remove) + (mew-nmz-setup) + (mew-nmz-mknmz-get-all-folders)) + +(defun mew-nmz-mark-unindexed () + "Mark unindexed messages." + (interactive) + (mew-summary-only + (if (mew-summary-exclusive-p) + (save-excursion + (if (and (mew-summary-mark-collect + mew-nmz-mark-unindexed (point-min) (point-max)) + (y-or-n-p (format "Unmark '%c'? " mew-nmz-mark-unindexed))) + (mew-mark-undo-mark mew-nmz-mark-unindexed 'nomsg)) + (let* ((ufname + (expand-file-name "NMZ.field.uri" + (mew-nmz-expand-folder (buffer-name)))) + (mmsgs 0) + (umsgs 0) + msgnums) + (if (not (file-exists-p ufname)) + (message "%s has no index file" (buffer-name)) + (with-temp-buffer + (message "checking %s..." (file-name-nondirectory ufname)) + (insert-file-contents ufname) + (while (re-search-forward "/\\([0-9]+\\)$" nil t) + (setq msgnums (cons (string-to-number (match-string 1)) msgnums)))) + (message "checking %s..." (buffer-name)) + (goto-char (point-min)) + (while (not (eobp)) + (if (and (mew-sumsyn-match mew-regex-sumsyn-short) + (not (memq (string-to-number (mew-sumsyn-message-number)) msgnums)) + (not (mew-in-decode-syntax-p))) + (progn + (setq umsgs (1+ umsgs)) + (when (mew-summary-markable) + (mew-summary-mark-as mew-nmz-mark-unindexed) + (setq mmsgs (1+ mmsgs))))) + (forward-line)) + (cond + ((= umsgs 1) + (message "%d message does not have index, %d marked" + umsgs mmsgs)) + ((> umsgs 1) + (message "%d messages do not have index, %d marked" + umsgs mmsgs)) + (t + (message "all messages have index"))))))))) + +;; "search Message-ID" functions. +(defun mew-nmz-search-parent (&optional child mid) + "Search *parent* message and jump to that. +If executed with '\\[universal-argument]', search *child* message." + (interactive "P") + (when (memq major-mode '(mew-summary-mode mew-virtual-mode)) + (mew-summary-goto-message)) + (let ((fld (mew-summary-folder-name)) + (msg (mew-summary-message-number)) + (idh (list (list mew-in-reply-to: mew-references:) + (list mew-message-id:))) + (message (if child "children" "parent")) + (refilefld (copy-sequence mew-nmz-search-parent-folder)) + (proto (or (mew-proto-to-refile (or (mew-sinfo-get-folder) + (mew-minfo-get-summary) + "+")) + "+")) + (case (mew-sinfo-get-case)) + refiledir mess ref pid pos killbuff) + (if mid + (setq pid (list mid) idh nil) + (if (not (or msg (mew-syntax-number))) + (message "No message here") + (save-excursion + (mew-nmz-setup) + (mew-summary-display) + (if (setq mess (mew-cache-hit fld msg)) + (set-buffer mess) + (setq mess (generate-new-buffer mew-buffer-prefix)) + (setq killbuff t) + (set-buffer mess) + (mew-erase-buffer) + (mew-insert-message + fld msg mew-cs-text-for-read mew-header-reasonable-size)) + (let ((mew-inherit-refile-proto proto) + (mew-inherit-refile-case case)) + (setq refilefld (append (car (mew-refile-guess nil t)) refilefld))) + (if child + (setq idh (car (cdr idh))) + (setq idh (car idh))) + (dolist (rh idh) + (setq ref (mew-header-get-value rh)) + (while (and ref (string-match "<\\([^>]+\\)>" ref)) + (setq pid (cons (concat "\"" (match-string 1 ref) "\"") pid)) + (setq refilefld + (cons (nth 1 (assoc (car pid) mew-refile-msgid-alist)) refilefld)) + (setq ref (substring ref (match-end 0))))) + (setq refilefld (cons fld refilefld)) + (setq refilefld (mew-uniq-list (delete nil refilefld))) + (setq refiledir + (delete nil (mapcar + (lambda (x) + (mew-nmz-expand-folder x)) + refilefld)))))) + (when killbuff (mew-kill-buffer mess)) + (if (null pid) + (message "No required header") + (if (mew-syntax-number) + (while (not (mew-summary-message-number)) + (forward-line -1))) + (mew-sinfo-set-ret-pos (point)) + (let ((pattern1 "") + (pattern2 "") + (addpattern (if child "+in-reply-to:" "+message-id:")) + (range nil)) + (if (not child) + (setq pattern1 (concat addpattern (car pid))) + (setq pattern1 (concat addpattern (car pid))) + (setq addpattern "+references:") + (setq pattern1 (concat pattern1 " | " addpattern (car pid)))) + (setq pid (delete (car pid) pid)) + (while pid + (if (> (length (concat pattern2 addpattern (car pid))) + mew-nmz-query-max-length) + (setq pid nil) + (setq pattern2 (concat pattern2 addpattern (car pid))) + (setq addpattern (if child " | +references:" " | +message-id:")) + (setq pid (delete (car pid) pid)))) + (message "Searching %s..." message) + (let ((pattern (list pattern1 pattern2))) + (while (and (null range) pattern) + (if mid + () + (message "Searching %s...%s" message (mew-join ", " refilefld)) + (setq range (mew-nmz-multi-pick refiledir (car pattern))) + (when range + (catch 'detect + (dolist (ref refilefld) + (if (null (setq idh (assoc ref range))) + () + (setq fld (car idh)) + (if child + (setq range (cdr idh)) + (setq range (nreverse (cdr idh)))) + (throw 'detect t))) + nil))) + (unless range + ;; all folder search + (message "Searching %s...all folders" message) + (setq range (mew-nmz-multi-pick + (mew-nmz-expand-folder-regexp "*:*") + (car pattern) 'catch)) + (if (null range) + (setq pattern (cdr pattern)) + (setq fld (car (car range))) + (setq range (cdr (car range))) + (if (not child) (setq range (nreverse range))) + )))) + (if (null range) + (message "No message found") + (when (or (and (mew-thread-p) + (string= (mew-summary-folder-name) fld)) + (and (mew-virtual-p) + (not (mew-thread-p)))) + (save-excursion + (goto-char (point-min)) + (when (re-search-forward + (concat "\r \\(" (regexp-quote fld) "\\)? +" (car range) " ") nil t) + (setq fld (buffer-name)) + (goto-char (match-beginning 0)) + (beginning-of-line) + (setq pos (point))))) + (if (listp (car range)) + (setq fld (car (car range)) + mess (car (cdr (car range)))) + (setq mess (car range))) + (mew-nmz-goto-folder-msg fld mess pos) + (message "Searching %s...%s/%s" message fld mess)))))) + +(defun mew-nmz-search-child (&optional arg) + (interactive "P") + (mew-nmz-search-parent (not arg))) + +(defun mew-nmz-search-msgid-at-point () + (interactive) + (let (start end) + (if (and (re-search-backward "<" (save-excursion (beginning-of-line) (point)) t) + (setq start (point)) + (re-search-forward ">" (save-excursion (end-of-line) (point)) t) + (setq end (point))) + (mew-nmz-search-msgid (buffer-substring start end)) + (message "No Message-ID")))) + +(defun mew-nmz-search-msgid-region (start end) + (interactive "r") + (mew-nmz-search-msgid (buffer-substring start end))) + +(defun mew-nmz-search-msgid (mid) + (interactive "sMessage-ID: ") + (if (string-match "<\\([^>]+\\)>" mid) + (let ((mew-use-full-window t) + (pattern (concat "\"" (mew-match-string 1 mid) "\""))) + (when (eq major-mode 'mew-message-mode) + (mew-message-goto-summary)) + (mew-nmz-search-parent nil pattern)) + (message "No Message-ID"))) + +;; "Namazu virtual" function. +(defun mew-nmz-input-folders () + (mew-input-clear) + (mew-input-folder-clean-up) + (let ((map (copy-keymap mew-input-folder-map)) + (case:folder (concat (or (mew-summary-folder-name) "+") + (if mew-nmz-input-folders-asterisk "*" "")))) + (define-key map "*" 'mew-input-folder-self-insert) + (let* ((init "+*") ;; (mew-canonicalize-case-folder case:folder)) + (mew-input-complete-function 'mew-complete-folder) + (mew-circular-complete-function 'mew-circular-complete-case:) + (mew-input-folder-search-multi t) + (minibuffer-setup-hook (cons 'backward-char minibuffer-setup-hook)) + ;; mew-inherit-case must be nil + (ret (read-from-minibuffer "Namazu folder name: " + init map nil + 'mew-nmz-input-folder-hist))) + (when (string= ret "") + (setq ret init)) + (setq ret (mapcar 'mew-chop (mew-split ret ?,)))))) + +;; Use namazu-mode. +;; (setq w3m-namazu-arguments +;; '("-r" "-h" "-H" "-n" w3m-namazu-page-max "-w" whence)) + +(defun mew-nmz-namazu (&optional pattern indexs) + "Execute w3m-namazu. +If executed with '\\[universal-argument]', search result indexes." + (interactive) + (if (not (or (featurep 'w3m-namazu) + (condition-case nil + (require 'w3m-namazu) + (error nil)))) + (message "Please install \"emacs-w3m\"") + (mew-nmz-setup) + (if current-prefix-arg + ;; rest indexes + (let (current-prefix-arg) + (mew-nmz-namazu mew-nmz-namazu-pattern mew-nmz-namazu-miss-folders)) + (let ((i mew-nmz-db-max) + flds nmzdirs fldmsgs pickflds overmsg) + (setq flds (or indexs (mew-nmz-input-folders))) + (setq mew-nmz-namazu-pattern + (setq pattern + (or pattern + (let ((mew-pick-field-list (mew-nmz-pick-field-list))) + (mew-nmz-pick-canonicalize-pattern + (mew-input-pick-pattern "Namazu pick")))))) + (setq mew-nmz-namazu-miss-folders nil) + (setq nmzdirs (mew-nmz-flds-to-indexs flds)) + (when (> (length nmzdirs) mew-nmz-db-max) + (setq fldmsgs (mew-nmz-multi-pick nmzdirs pattern)) + (when fldmsgs + (dolist (fldmsg fldmsgs) + (setq pickflds (cons (car fldmsg) pickflds))) + (when (> (length pickflds) mew-nmz-db-max) + (setq mew-nmz-namazu-miss-folders + (nthcdr mew-nmz-db-max (nreverse pickflds))) + (setq overmsg (format "Warning: %d indexes over" + (length mew-nmz-namazu-miss-folders)))) + (setq nmzdirs nil) + (while (and pickflds (> i 0)) + (setq nmzdirs (cons (mew-nmz-expand-folder (car pickflds)) + nmzdirs)) + (setq pickflds (cdr pickflds)) + (setq i (1- i))))) + ;; message viewer set + (unless (assoc mew-nmz-namazu-content-type w3m-content-type-alist) + (setq w3m-content-type-alist + (cons `(,mew-nmz-namazu-content-type "/[0-9]+$" nil "text/plain") + w3m-content-type-alist))) + (add-hook 'w3m-display-hook 'w3m-mew-message-view t) + ;; remove pre mew-nmz-namazu's alist + (when (assoc mew-nmz-namazu-index-alias w3m-namazu-index-alist) + (setq w3m-namazu-index-alist + (delete (assoc mew-nmz-namazu-index-alias w3m-namazu-index-alist) + w3m-namazu-index-alist))) + ;; for next page + (setq w3m-namazu-index-alist + (append (list (cons mew-nmz-namazu-index-alias nmzdirs)) + w3m-namazu-index-alist)) + (w3m-namazu mew-nmz-namazu-index-alias pattern 'reload) + (when overmsg (message overmsg)))))) + +(defun w3m-mew-message-view (url) + (if (and (boundp 'mew-mail-path) + (w3m-url-local-p url) + (string-match (concat (file-name-as-directory + (expand-file-name mew-mail-path)) + ".+/[0-9]+$") + (expand-file-name (w3m-url-to-file-name url)))) + (unless (get-text-property (point-min) 'w3m-mew-namazu) + (mew-elet + (goto-char (point-min)) + (condition-case nil + (let (pos) + (mew-decode-rfc822-header) + (mew-header-goto-end) + (mew-header-arrange (point-min) (point)) + (mew-highlight-body-region (point) (point-max)) + ;; for emacs-w3m + (remove-text-properties (point-min) (point-max) + '(read-only nil)) + (setq pos (if (get-text-property (point-min) 'mew-visible) + (point-min) + (or (next-single-property-change (point-min) 'mew-visible) + (point-min)))) + (set-window-start (selected-window) pos)) + (error nil)) + (put-text-property (point-min) (point-min) 'w3m-mew-namazu t) + (set-buffer-modified-p nil))) + (remove-text-properties (point-min) (point-min) '(w3m-mew-namazu nil)))) + +;; Input "Namazu pattern" functions. + +;; Mew pickpattern converter +(defun mew-nmz-pick-canonicalize-pattern (pattern) + (let ((mew-inherit-pick-omit-and t)) + (mapconcat + 'mew-nmz-pick-native-text-namazu + (mew-pick-parse (mew-pick-lex pattern)) + " "))) + +(defun mew-nmz-pick-native-text-namazu (token) + (mew-pick-native-text "mew-nmz-pick-pattern-namazu-" token)) + +(defun mew-nmz-pick-pattern-namazu-and (sym) "and") +(defun mew-nmz-pick-pattern-namazu-or (sym) "or") +(defun mew-nmz-pick-pattern-namazu-open (sym) "(") +(defun mew-nmz-pick-pattern-namazu-close (sym) ")") +(defun mew-nmz-pick-pattern-namazu-not (sym) "not") +(defun mew-nmz-pick-pattern-namazu-key (key) key) +(defun mew-nmz-pick-pattern-namazu-kyvl (kyvl) + (when (string= (nth 0 kyvl) "=") + (format "+%s:%s" (nth 1 kyvl) (nth 2 kyvl)))) + +(defun mew-nmz-pick-pattern-gather-header () + (when mew-nmz-pick-gather-field-list + (save-excursion + (let* ((fld (mew-summary-folder-name)) + (msg (mew-summary-message-number)) + (buf (mew-cache-hit fld msg)) + (gathers mew-nmz-pick-gather-field-list) + killbuff retlst gather header duplchk mid addrs addr prefix) + (when (and (not buf) fld msg) + (setq buf (generate-new-buffer mew-buffer-prefix)) + (setq killbuff t) + (set-buffer buf) + (mew-erase-buffer) + (mew-insert-message + fld msg mew-cs-text-for-read mew-header-reasonable-size)) + (when (and buf (get-buffer buf) (buffer-name (get-buffer buf))) + (set-buffer buf) + (while gathers + (setq gather (car gathers)) + (setq header (mew-header-get-value (car gather))) + (when (and header (car (cdr gather))) + (cond + ((eq (car (cdr gather)) 'msgid) + (while (and header (string-match "<\\([^>]+\\)>" header)) + (setq mid (match-string 1 header)) + (setq header (substring header (match-end 0))) + (if (member mid duplchk) + () + (setq prefix (nthcdr 2 gather)) + (setq duplchk (cons mid duplchk)) + (while prefix + (setq retlst (cons (concat (car prefix) mid) retlst)) + (setq prefix (cdr prefix)))))) + ((eq (car (cdr gather)) 'address) + (setq addrs (mew-addrstr-parse-address-list header)) + (while (setq addr (car addrs)) + (setq addr (downcase addr)) + (if (not (member addr duplchk)) + (let ((prefix (nthcdr 2 gather))) + (setq duplchk (cons addr duplchk)) + (while prefix + (setq retlst (cons (concat (car prefix) addr) retlst)) + (setq prefix (cdr prefix))))) + (setq addrs (cdr addrs)))))) + (setq gathers (cdr gathers))) + (when killbuff (mew-kill-buffer buf)) + (when retlst + (setq retlst (append + retlst + (list + (concat " " (make-string (- (window-width) 10) ?-)))))) + (nreverse retlst)))))) + +;; "Namazu search engine" functions. +(defun mew-nmz-multi-pick (nmzdirs pattern &optional catch single) + "Get message numbers with many folders." + (let ((tmpdirs nmzdirs) + (defaultregex + (concat "^" (regexp-opt + (delq mew-folder-virtual (copy-sequence mew-folder-prefixes))))) + nxt prog-args intmsgs retmsgs sortfld defmsgs casemsgs cell) + (setq pattern (mew-cs-encode-arg pattern)) + (setq nmzdirs nil) + (while tmpdirs + (setq nxt (nthcdr mew-nmz-db-max tmpdirs)) + (if nxt (setcdr (nthcdr (1- mew-nmz-db-max) tmpdirs) nil)) + (setq nmzdirs (cons tmpdirs nmzdirs)) + (setq tmpdirs nxt)) + (setq nmzdirs (nreverse nmzdirs)) + (with-temp-buffer + (while (and nmzdirs + (or (not catch) + (and catch (null intmsgs)))) + (setq prog-args (delq nil (append mew-nmz-prog-args + (list "--all" "--list" "--no-decode-uri") + (list pattern) + (car nmzdirs)))) + (erase-buffer) + (mew-piolet + mew-cs-text-for-read mew-cs-text-for-write + (let ((file-name-coding-system nil)) + (apply (function call-process) + mew-nmz-prog nil t nil prog-args))) + (goto-char (point-min)) + (let (dir msgnum) + (while (not (eobp)) + (when (looking-at mew-nmz-result-regex) + (setq dir (mew-buffer-substring (match-beginning 1) (match-end 1))) + (setq msgnum (string-to-number + (mew-buffer-substring (match-beginning 2) (match-end 2)))) + (if (not (setq cell (assoc dir intmsgs))) + (setq intmsgs (cons (list dir (list msgnum)) intmsgs)) + (unless (memq msgnum (car (cdr cell))) + (nconc (car (cdr cell)) (list msgnum))))) + (forward-line)) + (setq nmzdirs (cdr nmzdirs)))) + (when intmsgs + (if single + ;; for search-mark + (mapcar 'number-to-string (sort (car (cdr (car intmsgs))) '<)) + ;; for virtual or w3m-namazu + (setq retmsgs intmsgs) + (while retmsgs + (setq sortfld (cons (car (car retmsgs)) sortfld)) + (setq retmsgs (cdr retmsgs))) + ;; no sort + ;; (setq sortfld (sort sortfld 'string<)) + (while sortfld + (setq cell (assoc (car sortfld) intmsgs)) + (setq retmsgs + (cons + (cons (mew-nmz-url-to-folder (car cell)) + (mapcar 'number-to-string (sort (car (cdr cell)) '<))) + retmsgs)) + (setq sortfld (cdr sortfld))) + ;; '((folder msg ...) (folder msg ...) ...) + (while retmsgs + (when (car (car retmsgs)) + (if (string-match defaultregex (car (car retmsgs))) + (setq defmsgs (cons (car retmsgs) defmsgs)) + (setq casemsgs (cons (car retmsgs) casemsgs)))) + (setq retmsgs (cdr retmsgs))) + (append defmsgs casemsgs)))))) + +;; miscellaneous functions +(defun mew-nmz-flds-to-indexs (flds) + (let ((suffix (append + '("*") + (delq mew-folder-virtual (copy-sequence mew-folder-prefixes)))) + nmzdirs tmp) + (setq suffix (concat (regexp-opt suffix) "$")) + (dolist (fld flds) + (setq fld (mew-nmz-case-folder-normalize fld)) + (cond + ((or (string-match suffix fld) + (string-match "^\\*" fld)) + (setq nmzdirs (append nmzdirs + (mew-nmz-expand-folder-regexp fld)))) + ((setq tmp (mew-nmz-folder-to-nmzdir fld)) + (setq nmzdirs (cons tmp nmzdirs))))) + (nreverse (mew-uniq-list nmzdirs)))) + +(defun mew-nmz-expand-folder-regexp (case:folder) + (mew-nmz-setup) + (let ((alist mew-nmz-fld-index-alist) + case fld caseregex nmzdirs tmpfld nmzdir protos newcase lst) + (if (string= case:folder "*:*") + ;; all case, all proto, all folder + (dolist (lst alist) + (setq nmzdirs (cons (cdr lst) nmzdirs))) + (if (string-match "^\\([^:]+\\):\\(.*\\)$" case:folder) + (setq case (match-string 1 case:folder) + fld (match-string 2 case:folder)) + (setq case "") + (setq fld case:folder)) + (when (string-match "^.*\\*$" fld) + (setq fld (substring fld 0 -1)) + (setq fld (directory-file-name fld))) + (cond + ((string= case "*") + ;; all case + (setq caseregex "^\\([^:]+:\\)?")) + ((or (string= case "") (string= mew-case-default case)) + ;; default case + (setq caseregex "^")) + ((string= fld "") + (setq protos (delq mew-folder-virtual (copy-sequence mew-folder-prefixes))) + (setq caseregex + (concat "^\\(\\(" + (mapconcat + (lambda (x) + (setq newcase (mew-nmz-case-normalize + (concat case ":" x))) + (if (string= newcase "") + (regexp-quote x) + (regexp-quote (concat case ":" x)))) + protos "\\)\\|\\(") + "\\)\\)"))) + (t + (setq case (mew-nmz-case-normalize (concat case ":" fld))) + (if (string= case "") + (setq caseregex "^") + (setq caseregex (concat "^" (regexp-quote case) ":"))))) + (if (string= fld "") + (setq caseregex (concat caseregex "[^:]+$")) + (setq caseregex (concat caseregex (regexp-quote fld)))) + (dolist (lst alist) + (setq tmpfld (car lst)) + (setq nmzdir (cdr lst)) + (when (string-match caseregex tmpfld) + (setq nmzdirs (cons nmzdir nmzdirs))))) + nmzdirs)) + +(defun mew-nmz-goto-folder-msg (fld msg &optional pos disp) + (when (string-match "^+#" fld) + (mew-nmz-setup) + (setq fld (or (cdr (assoc (mew-expand-folder fld) mew-nmz-url-fld-alist)) + fld))) + (mew-summary-visit-folder fld) + (if (mew-virtual-p) + (mew-summary-move-and-display msg disp) + (goto-char (point-min)) + (if (mew-nmz-re-search-message msg) + (setq pos (point)) + (setq pos + (catch 'det + (while mew-summary-buffer-process + (sit-for 0.1) + ;; accept-process-output or sleep-for is not enough + (discard-input) + (unless pos + (goto-char (point-min)) + (when (mew-nmz-re-search-message msg) + (setq pos (point)) + (throw 'det t)))) + pos))) + (if pos (goto-char pos)) + (mew-thread-move-cursor) + (mew-summary-display disp))) + +(defun mew-nmz-index-new-p (fld) + (let ((touchtime (mew-file-get-time + (expand-file-name + mew-summary-touch-file + (file-chase-links (mew-expand-folder fld))))) + (stamptime (mew-file-get-time + (expand-file-name + "NMZ.stamp" (mew-nmz-expand-folder fld))))) + (cond + ((null touchtime) nil) + ((null stamptime) nil) + ((> (nth 0 stamptime) (nth 0 touchtime)) t) + ((and (= (nth 0 stamptime) (nth 0 touchtime)) + (> (nth 1 stamptime) (nth 1 touchtime))) t) + (t nil)))) + +(defun mew-nmz-index-delete (nmzdir &optional tmpfiles) + "Delete namazu index files." + (when (file-directory-p nmzdir) + (let* ((regex (if tmpfiles "^NMZ\..*tmp$" "^NMZ\.")) + (flist (directory-files nmzdir 'full regex 'nosort))) + (dolist (file flist) + (setq file (expand-file-name file nmzdir)) + (and (file-exists-p file) + (file-writable-p file) + (delete-file file)))))) + +(defun mew-nmz-skip-folder-p (fld) + (let ((skips mew-nmz-mknmz-skip-folders-regexp)) + (catch 'match + (setq fld (mew-nmz-case-folder-normalize fld)) + (dolist (skip skips) + (when (string-match skip fld) + (throw 'match t))) + nil))) + +(defun mew-nmz-gcnmz-folder-p (fld) + (let ((regexps mew-nmz-use-gcnmz-folders-regexp)) + (catch 'match + (setq fld (mew-nmz-case-folder-normalize fld)) + (while regexps + (when (string-match (car regexps) fld) + (throw 'match t)) + (setq regexps (cdr regexps))) + nil))) + +(defun mew-nmz-timestamp-new (fld) + (let ((file (expand-file-name "NMZ.stamp.new" (mew-nmz-expand-folder fld)))) + (if (file-writable-p file) + (write-region "touched by Mew." nil file nil 'no-msg)))) + +(defun mew-nmz-timestamp-rename (fld) + (let ((nfile (expand-file-name "NMZ.stamp.new" (mew-nmz-expand-folder fld))) + (tfile (expand-file-name "NMZ.stamp" (mew-nmz-expand-folder fld)))) + (if (and (file-readable-p nfile) (file-writable-p tfile)) + (rename-file nfile tfile 'ok) + (if (file-writable-p nfile) + (delete-file nfile))))) + +(defun mew-nmz-re-search-message (msg) + (let ((here (point))) + (if (not (re-search-forward (concat "^.*\r +" msg "[^0-9]") nil t)) + (progn (goto-char here) + nil) + (beginning-of-line) + t))) + +;; index delete/rename +;; call from mew-summary-delete-folder() +;; case:folder MUST not branch +(defun mew-nmz-folder-index-delete (case:folder) + (let ((nmzdir (mew-nmz-expand-folder case:folder)) + (fld (mew-nmz-case-folder-normalize case:folder))) + (when (and (file-exists-p nmzdir) (file-directory-p nmzdir)) + (mew-delete-directory-recursively nmzdir) + (setq mew-nmz-fld-index-alist + (delete (assoc fld mew-nmz-fld-index-alist) mew-nmz-fld-index-alist)) + (setq mew-nmz-url-fld-alist + (delete (assoc (mew-expand-folder fld) mew-nmz-url-fld-alist) + mew-nmz-url-fld-alist)) + (mew-nmz-cache-save)))) + +;; call from mew-summary-rename-folder() +(defun mew-nmz-folder-index-rename (case:folder case:new-folder) + (let ((nmzdir (mew-nmz-expand-folder case:folder)) + (new-nmzdir (mew-nmz-expand-folder case:new-folder)) + (dir (file-name-as-directory (mew-expand-folder case:folder))) + (new-dir (file-name-as-directory (mew-expand-folder case:new-folder)))) + (when (and (file-exists-p nmzdir) (file-directory-p nmzdir) + (not (file-exists-p new-nmzdir))) + (mew-nmz-cleanup 'remove) + (rename-file nmzdir new-nmzdir) + (when mew-nmz-use-drive-letter + (when (string-match "^\\([a-zA-Z]\\):\\(/.*\\)" dir) + (setq dir (concat "/" + (substring dir (match-beginning 1) (match-end 1)) + "|" + (substring dir (match-beginning 2) (match-end 2))))) + (when (string-match "^\\([a-zA-Z]\\):\\(/.*\\)" new-dir) + (setq new-dir (concat "/" + (substring new-dir (match-beginning 1) (match-end 1)) + "|" + (substring new-dir (match-beginning 2) (match-end 2)))))) + (mew-nmz-folder-reindex-recursively new-nmzdir dir new-dir)))) + +(defun mew-nmz-folder-reindex-recursively (dir from to) + (let ((files (directory-files dir 'full mew-regex-files 'no-sort)) + urifile) + (when (member (setq urifile (expand-file-name "NMZ.field.uri" dir)) files) + (mew-nmz-folder-index-reindex dir urifile from to)) + (dolist (file files) + (when (file-directory-p file) + (mew-nmz-folder-reindex-recursively file from to))))) + +(defun mew-nmz-folder-index-reindex (dir file from to) + (setq from (concat "^" (regexp-quote from))) + (when (and (file-readable-p file) (file-regular-p file)) + (message "mew-nmz: reindexing %s..." dir) + (with-temp-buffer + (mew-frwlet + mew-cs-autoconv mew-nmz-cs-index + (insert-file-contents file) + (goto-char (point-min)) + (while (not (eobp)) + (when (looking-at from) + (delete-region (match-beginning 0) (match-end 0)) + (insert to)) + (forward-line 1)) + (write-region (point-min) (point-max) file nil 'nomsg))) + (when (mew-which-exec mew-nmz-prog-rfnmz) + (call-process mew-nmz-prog-rfnmz nil nil nil dir)) + (message "mew-nmz: reindexing %s...done" dir))) + +;; mew-nmz-setup +(defun mew-nmz-gather-indexed-folder (case folders-alist &optional proto) + (let ((ocase case) + fld nmzdir fld-index-alist url-fld-alist) + (unless case (setq case "")) + (dolist (flds folders-alist) + (setq fld (car flds)) + (when fld + (when (eq proto 'imap) + (setq fld (mew-nmz-imap-directory-file-name fld ocase))) + (setq fld (directory-file-name (if (string= case "") + fld + (concat case ":" fld)))) + (when (and (or (not (eq proto 'nntp)) + (file-directory-p (mew-expand-folder fld))) + (setq nmzdir (mew-nmz-expand-folder fld)) + (file-directory-p nmzdir) + (file-exists-p (expand-file-name "NMZ.i" nmzdir))) + (setq fld-index-alist (cons (cons fld nmzdir) fld-index-alist)) + (setq url-fld-alist (cons (cons (mew-expand-folder fld) fld) url-fld-alist))))) + (setq mew-nmz-fld-index-alist + (append mew-nmz-fld-index-alist (nreverse fld-index-alist))) + (setq mew-nmz-url-fld-alist + (append mew-nmz-url-fld-alist (nreverse url-fld-alist))))) + +(defun mew-nmz-setup () + (unless mew-nmz-setup-p + (unless (and (mew-which-exec mew-nmz-prog-mknmz) + (mew-which-exec mew-nmz-prog)) + (error "Please install namazu")) + (message "mew-nmz setup...") + (unless (mew-nmz-cache-load) + (mew-nmz-cleanup) + (let ((prefixes (delq mew-folder-virtual (copy-sequence mew-folder-prefixes))) + nmzdir-case-alist + case-alist cases case ocase gcase nmzdir alst) + (dolist (prefix prefixes) + (setq cases (mapcar (lambda (x) + (if (string= x mew-case-default) "" x)) + mew-config-cases)) + (when (member "" cases) + (setq cases (cons "" (delete "" cases)))) + (setq nmzdir-case-alist nil) + (setq case-alist nil) + (setq gcase nil) + (while (setq case (car cases)) + (setq nmzdir (mew-nmz-expand-folder (if (string= case "") + prefix + (concat case ":" prefix)))) + (if (setq alst (assoc nmzdir nmzdir-case-alist)) + (progn + (setq ocase (car (assoc (cdr alst) case-alist))) + (setq case-alist (cons (cons case ocase) case-alist))) + (setq nmzdir-case-alist + (cons (cons nmzdir case) nmzdir-case-alist)) + (setq case-alist (cons (cons case case) case-alist)) + (setq gcase (cons case gcase))) + (setq cases (cdr cases))) + (setq gcase (nreverse gcase)) + (cond + ((mew-folder-imapp prefix) + (setq mew-nmz-imap-case-alist (nreverse case-alist)) + (while (setq case (car gcase)) + (mew-nmz-gather-indexed-folder case (mew-imap-folder-alist case) 'imap) + (setq gcase (cdr gcase)))) + ((mew-folder-popp prefix) + (setq mew-nmz-pop-case-alist (nreverse case-alist)) + (while (setq case (car gcase)) + (mew-nmz-gather-indexed-folder case `((,mew-pop-inbox-folder))) + (setq gcase (cdr gcase)))) + ((mew-folder-nntpp prefix) + (setq mew-nmz-nntp-case-alist (nreverse case-alist)) + (while (setq case (car gcase)) + (mew-nmz-gather-indexed-folder case (mew-nntp-folder-alist case) 'nntp) + (setq gcase (cdr gcase)))) + (t ;; local + (mew-nmz-gather-indexed-folder nil (mew-local-folder-alist))))) + (mew-nmz-cache-save))) + (message "mew-nmz setup...done") + (setq mew-nmz-setup-p t) + (run-hooks 'mew-nmz-setup-hook))) + +(defun mew-nmz-status-update () + (mew-nmz-cleanup 'remove)) + +(defconst mew-nmz-cache-parts '(imap-case nntp-case pop-case fld-index url-fld)) + +(defun mew-nmz-cleanup (&optional remove) + (if remove (mew-nmz-cache-remove)) + (setq mew-nmz-setup-p nil) + (let ((parts (copy-sequence mew-nmz-cache-parts))) + (dolist (part parts) + (set (mew-nmz-cache-alist-name part) nil)))) + +(defun mew-nmz-cache-save () + (when (stringp mew-nmz-cache-file-prefix) + (let ((parts (copy-sequence mew-nmz-cache-parts)) + file alist) + (dolist (part parts) + (setq file (mew-nmz-cache-file-name part)) + (setq alist (symbol-value (mew-nmz-cache-alist-name part))) + (mew-lisp-save file alist 'nobackup 'unlimit))))) + +(defun mew-nmz-cache-load () + (when (stringp mew-nmz-cache-file-prefix) + (let ((parts (copy-sequence mew-nmz-cache-parts)) + file) + (catch 'noexist + (dolist (part parts) + (setq file (mew-nmz-cache-file-name part)) + (if (file-readable-p file) + (set (mew-nmz-cache-alist-name part) (mew-lisp-load file)) + (throw 'noexist nil))) + t)))) + +(defun mew-nmz-cache-remove () + (when (stringp mew-nmz-cache-file-prefix) + (let ((parts (copy-sequence mew-nmz-cache-parts)) + file) + (dolist (part parts) + (setq file (mew-nmz-cache-file-name part)) + (when (and (file-exists-p file) (file-writable-p file)) + (delete-file file)))))) + +;; mew-nmz-fixer +;; to be continue ... + +(provide 'mew-nmz) + +;;; Copyright Notice: + +;; Copyright (C) 1999-2007 Hideyuki SHIRAI +;; Copyright (C) 1994-2007 Mew developing team. +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. Neither the name of the team nor the names of its contributors +;; may be used to endorse or promote products derived from this software +;; without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; mew-nmz.el ends here diff -urN mew.orig/contrib/mew-refile-view.el mew/contrib/mew-refile-view.el --- mew.orig/contrib/mew-refile-view.el 1970-01-01 09:00:00.000000000 +0900 +++ mew/contrib/mew-refile-view.el 2011-06-15 00:20:15.000000000 +0900 @@ -0,0 +1,443 @@ +;;; mew-refile-view.el --- View refile alist + +;; Author: Takashi P.KATOH +;; Created: Oct 22, 1998 +;; Revised: Jan 06, 2004 + +;;; Code: + +(defconst mew-refile-view-version "mew-refile-view.el version 0.07") + +(require 'mew) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; User customize variables +;;; + +;; -> mew-vars.el ? +(defvar mew-refile-view-exec-confirm t + "*Non nil means `mew-refile-view-exec' prompts the user for +confirmation before refiling.") + +(defvar mew-refile-view-show-trash nil + "*Non nil means trash folder (i.e. delete-marked messages) +will be also shown.") + +(defvar mew-refile-view-mode-hook nil) +(defvar mew-refile-view-mode-map nil) + +(defvar mew-refile-view-mode-menu-spec + '("Mew/RefileView" + ["Next page" scroll-up t] + ["Prev page" scroll-down t] + ["Top" beginning-of-buffer t] + ["Bottom" end-of-buffer t] + ["Prev message" mew-refile-view-prev-msg t] + ["Next message" mew-refile-view-next-msg t] + "----" + ["Show again" mew-refile-view-again t] + ["Goto summary" mew-refile-view-goto-summary t] + ["Unmark (single refile folder)" mew-refile-view-unmark-one t] + ["Unmark" mew-refile-view-unmark t] + ["Refile" mew-refile-view-refile t] + ["Delete" mew-refile-view-delete t] + ["Quit" mew-refile-view-quit t] + )) + +(if mew-refile-view-mode-map + () + (setq mew-refile-view-mode-map (make-sparse-keymap)) + (define-key mew-refile-view-mode-map " " 'scroll-up) + (define-key mew-refile-view-mode-map "\177" 'scroll-down) + (define-key mew-refile-view-mode-map "." 'mew-refile-view-goto-summary) + (define-key mew-refile-view-mode-map "h" 'mew-refile-view-goto-summary) + (define-key mew-refile-view-mode-map "n" 'mew-refile-view-next-msg) + (define-key mew-refile-view-mode-map "p" 'mew-refile-view-prev-msg) + (define-key mew-refile-view-mode-map "N" 'mew-refile-view-next-fld) + (define-key mew-refile-view-mode-map "P" 'mew-refile-view-prev-fld) + (define-key mew-refile-view-mode-map "l" 'mew-refile-view-again) + (define-key mew-refile-view-mode-map "u" 'mew-refile-view-unmark-one) + (define-key mew-refile-view-mode-map "U" 'mew-refile-view-unmark) + (define-key mew-refile-view-mode-map "o" 'mew-refile-view-refile) + (define-key mew-refile-view-mode-map "d" 'mew-refile-view-delete) + (define-key mew-refile-view-mode-map "x" 'mew-refile-view-exec) + (define-key mew-refile-view-mode-map "q" 'mew-refile-view-quit) + (define-key mew-refile-view-mode-map "Q" 'mew-refile-view-exit) + (define-key mew-refile-view-mode-map "<" 'beginning-of-buffer) + (define-key mew-refile-view-mode-map ">" 'end-of-buffer) + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Refile view mode +;;; + +(defun mew-re-search-forward-and-backward (regexp bound noerror) + (or (re-search-forward regexp bound noerror) + (re-search-backward regexp bound noerror))) + +;; -> mew-vars ? +(defconst mew-refile-view-folder-regex "^[*+=]") +(defvar mew-original-folder nil) + +(defun mew-assoc-add (key alist mem) + (append (list (append (or (assoc key alist) (list key)) (list mem))) + (delete (assoc key alist) alist))) + +(defun mew-car-string< (a1 a2) + (let ((k1 (car a1)) (k2 (car a2))) + (string< k1 k2))) + +(defun mew-refile-view-make-alist (msg) + ;; (mew-sinfo-get-refile) -> '(("+foo" "1" "2") ("+bar" "4" "3")) + (let ((alist + (mapcar '(lambda (msg) (assoc msg (mew-sinfo-get-refile))) msg)) + result) + (while alist + (let ((flist (cdr (car alist)))) + (while flist + (setq result (mew-assoc-add (car flist) result (car (car alist))) + flist (cdr flist)))) + (setq alist (cdr alist))) + result)) + +(defun mew-refile-view (&optional prefix) + (interactive "P") + (mew-pickable + (if (interactive-p) + (mew-current-set-window-config)) + (let* ((folder (buffer-name)) + (bufname (format "*Mew refile view* (%s)" folder)) + (mew-refile-view-show-trash (or prefix mew-refile-view-show-trash)) + (refile (mew-summary-mark-collect mew-mark-refile + (point-min) (point-max))) + (trash + (if mew-refile-view-show-trash + (mew-summary-mark-collect mew-mark-delete + (point-min) (point-max)) + nil)) + (unlink + (if mew-refile-view-show-trash + (mew-summary-mark-collect mew-mark-unlink + (point-min) (point-max)) + nil)) + (ofld (substring folder 1)) + tmp) + (if (and (mew-thread-p) (get-buffer ofld)) + (progn + (save-excursion + (set-buffer ofld) + (setq tmp (mew-sinfo-get-refile))) + (mew-sinfo-set-refile tmp))) + (if (not (or refile trash unlink)) + (progn + (message "No refile marks") + (if (buffer-live-p (get-buffer bufname)) + (progn + (set-buffer bufname) + (setq buffer-read-only nil) + (erase-buffer) + (insert "No refile marks\n") + (setq buffer-read-only t)))) + (let ((alist (mew-refile-view-make-alist refile)) + tmpalist view summary num numlist) + (setq view (pop-to-buffer bufname)) + (setq buffer-read-only nil) + (erase-buffer) + (mew-buffers-setup bufname) + + (setq tmpalist alist) + (setq alist nil) + (while tmpalist + (if (string= mew-trash-folder (car (car tmpalist))) + (progn + (setq trash (append (cdr (car tmpalist)) trash)) + (setq alist (append (cdr tmpalist) alist)) + (setq tmpalist nil)) + (setq alist (cons (car tmpalist) alist)) + (setq tmpalist (cdr tmpalist)))) + ;; + (setq alist (sort alist 'mew-car-string<)) + (if trash + (setq alist (append alist (list (cons mew-trash-folder trash))))) + (if unlink + (setq alist (append alist (list (cons "+REMOVE" unlink))))) + (while alist + (set-buffer view) + (insert (concat (car (car alist)) "\n")) + (setq numlist (sort (mapcar 'string-to-int (cdr (car alist))) '<)) + (while numlist + (setq num (car numlist) + numlist (cdr numlist)) + ;; + (set-buffer (get-buffer folder)) + ;; Mew4 + (when (mew-re-search-forward-and-backward + (mew-regex-sumsyn-msg (int-to-string num)) nil t) + (if (mew-thread-p) + (setq summary + (concat + (mew-buffer-substring (line-beginning-position) + (progn (move-to-column (mew-vinfo-get-column)) + (point))) + (mew-buffer-substring (let ((mew-use-thread-cursor t)) + (progn (mew-thread-move-cursor) (point))) + (line-end-position)))) + (setq summary (mew-buffer-substring (line-beginning-position) + (line-end-position)))) + ;; + (set-buffer view) + (insert summary) + (let ((mew-highlight-mark-folder-list (list bufname))) + (mew-mark-unmark)) + (insert "\n"))) + (insert "\n") + (setq alist (cdr alist))) + (goto-char (point-min)) + (mew-refile-view-mode + (if (string-match mew-refile-view-folder-regex folder) + folder nil))) + )))) + +(defun mew-refile-view-goto-summary () + "Get back to Summary mode." + (interactive) + (let (num) + (save-excursion + (beginning-of-line) + (setq num (if (looking-at (concat "^[^\r\n]+" mew-regex-sumsyn-short)) + (mew-match-string 2)))) + (if (not (and mew-original-folder (get-buffer mew-original-folder))) + (progn + (message "No Summary buffer for %s" mew-original-folder) + nil) + (if (get-buffer-window mew-original-folder) + (select-window (get-buffer-window mew-original-folder)) + (mew-summary-switch-to-folder mew-original-folder)) + (if num (mew-summary-move-and-display num)) + t))) + +(defun mew-refile-view-again () + (interactive) + (if (not (and mew-original-folder (get-buffer mew-original-folder))) + (message "No Summary buffer for %s" mew-original-folder) + (set-buffer mew-original-folder) + (mew-refile-view))) + +(defun mew-refile-view-quit () + "Exit from mew-refile-view-mode." + (interactive) + (bury-buffer (current-buffer)) + (delete-windows-on (current-buffer)) + (mew-current-get-window-config)) + +(defun mew-refile-view-exit () + "Exit from mew-refile-view-mode." + (interactive) + (let ((buf (current-buffer))) + (delete-windows-on (current-buffer)) + (kill-buffer buf) + (mew-current-get-window-config))) + +(defun mew-refile-view-next-msg () + "Move to next message in Mew refile view buffer." + (interactive) + (let ((orig (point))) + (end-of-line) + (if (re-search-forward mew-regex-sumsyn-short nil t) + (beginning-of-line) + (goto-char orig)))) + +(defun mew-refile-view-prev-msg () + "Move to previous message in Mew refile view buffer." + (interactive) + (let ((orig (point))) + (beginning-of-line) + (if (re-search-backward mew-regex-sumsyn-short nil t) + (beginning-of-line) + (goto-char orig)))) + +(defun mew-refile-view-next-fld () + (interactive) + (let ((orig (point))) + (end-of-line) + (if (or (re-search-forward "^[+%=]" nil t) + (re-search-forward "^$" nil t)) + (beginning-of-line) + (goto-char orig)))) + +(defun mew-refile-view-prev-fld () + (interactive) + (let ((orig (point))) + (beginning-of-line) + (if (re-search-backward "^[+%=]" nil t) + (beginning-of-line) + (goto-char orig)))) + +(defun mew-refile-view-exec () + (interactive) + (if (not (and mew-original-folder (get-buffer mew-original-folder))) + (message "No Summary buffer for %s" mew-original-folder) + (if (or (not mew-refile-view-exec-confirm) + ;; or yes-or-no-p? + (y-or-n-p "Execute refiling for these messages? ")) + (let ((fld mew-original-folder) + thread) + (save-excursion + (if (save-excursion + (set-buffer fld) + (and (mew-thread-p) + (get-buffer (substring fld 1)))) + (progn + (setq thread t) + (set-buffer (substring fld 1))) + (set-buffer fld)) + (mew-summary-exec)) + (mew-refile-view-exit) + (if thread + (progn + (mew-kill-buffer fld) + (mew-summary-switch-to-folder (substring fld 1)))))))) + + +(defun mew-refile-view-unmark-one () + "Unmark this message. +If this message has multi-refile folders, remove one of them." + (interactive) + (mew-refile-view-msg 'undo 'one)) + +(defun mew-refile-view-unmark () + "Unmark this message." + (interactive) + (mew-refile-view-msg 'undo)) + +(defun mew-refile-view-refile () + "Refile this message." + (interactive) + (mew-refile-view-msg 'refile)) + +(defun mew-refile-view-delete () + "Delete this message." + (interactive) + (mew-refile-view-msg 'delete)) + +(defun mew-refile-view-msg (op &optional one) + (beginning-of-line) + (let ((orig-point (point)) + (orig-buff (current-buffer)) + msg reffld bufref fld ofld tmp) + (if (not (looking-at (concat "^[^\r\n]+" mew-regex-sumsyn-short))) + (message "No message") + (setq msg (mew-match-string 2)) + (if one + (save-excursion + (if (re-search-backward + (concat mew-refile-view-folder-regex ".+$") + nil t) + (setq reffld (buffer-substring (match-beginning 0) + (match-end 0)))))) + ;; in mew summary buffer + (if (mew-refile-view-goto-summary) + (mew-pickable + (cond + ((eq op 'refile) + (mew-summary-refile)) + ((eq op 'undo) + (if (not (and one msg reffld)) + (mew-summary-undo 1) + (setq bufref (assoc msg (mew-sinfo-get-refile))) + (if (< (length bufref) 3) + (mew-summary-undo 1) + ;; remove 1 folder + (setq bufref (delete reffld bufref)) + (setq tmp (mew-sinfo-get-refile)) + (mew-replace-with tmp bufref msg) + (mew-sinfo-set-refile tmp) + (if (mew-thread-p) + (progn + (setq fld (mew-summary-folder-name 'ext)) + (setq ofld (substring fld 1)) + (if (get-buffer ofld) + (save-excursion + (set-buffer ofld) + (mew-sinfo-set-refile tmp)))))))) + ((eq op 'delete) + (mew-summary-delete 1))) + (mew-refile-view))) + ;; we are out of mew summary buffer now + (pop-to-buffer orig-buff) + (if (< orig-point (point-max)) + (goto-char orig-point) + (goto-char (point-max))) + (beginning-of-line)))) + +(defun mew-refile-view-mode (&optional folder) + "Major mode for viewing refile alist. +The keys defined for this mode are: + +SPC Scroll up this message. +DEL Back-scroll this message. +. Get back to Summary mode. +h Get back to Summary mode. +n Move to next message. +p Move to previous message. +N Move to next folder. +P Move to previous folder. +l Reshow . +u Unmark. +o Refile again. +d Put delete mark on this message. +x Process marked messages. +q Quit. +Q Exit. +< Go to top. +> Go to bottom. +" + (interactive) + (setq major-mode 'mew-refile-view-mode) + (setq mode-name "Refile-View") + (setq mode-line-buffer-identification mew-mode-line-id) + (use-local-map mew-refile-view-mode-map) + (setq buffer-read-only t) + (setq selective-display t) + (setq selective-display-ellipses nil) + (setq truncate-lines t) + (make-local-variable 'mew-original-folder) + (setq mew-original-folder folder) + (mew-buffers-setup (buffer-name)) + (run-hooks 'mew-refile-view-mode-hook)) + +(provide 'mew-refile-view) + +;;; Copyright Notice: + +;; Copyright (C) 1998, 1999 Mew developing team. +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. Neither the name of the team nor the names of its contributors +;; may be used to endorse or promote products derived from this software +;; without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; mew-refile-view.el ends here diff -urN mew.orig/contrib/mew-toolbar-frame.el mew/contrib/mew-toolbar-frame.el --- mew.orig/contrib/mew-toolbar-frame.el 1970-01-01 09:00:00.000000000 +0900 +++ mew/contrib/mew-toolbar-frame.el 2011-06-15 00:20:15.000000000 +0900 @@ -0,0 +1,90 @@ +;;; mew-toolbar-frame.el -*-Emacs-Lisp-*- +;;; +;;; Commentary: +;;; Run Mew from toolbar in a separate frame. +;;; +;;; Keywords: +;;; Mew Xemacs ToolBar Frame +;;; +;;; Time-stamp: <99/07/02 16:37:17 jado@sophia> + +;;; How to use: +;;; Require it when initialize. + +;;; Code: + +(provide 'mew-toolbar-frame) + +;;; + +(setq toolbar-mail-reader 'Mew) +(setq toolbar-mail-commands-alist + (cons '(Mew . toolbar-mew) toolbar-mail-commands-alist)) + +(defvar toolbar-mail-use-separate-frame t + "*Whether Mew is invoked in a separate frame.") +(defvar toolbar-mail-frame nil + "The frame in which Mew is displayed.") +(defvar toolbar-mail-frame-plist nil + "*The properties of the frame in which mail is displayed.") +(define-obsolete-variable-alias 'toolbar-mail-frame-properties + 'toolbar-mail-frame-plist) + +(defun toolbar-mew () + "Run Mew in a separate frame." + (interactive) + (if (not toolbar-mail-use-separate-frame) + (mew) + (unless (frame-live-p toolbar-mail-frame) + (setq toolbar-mail-frame (make-frame toolbar-mail-frame-plist)) + (add-hook 'mew-suspend-hook + (lambda () + (when (frame-live-p toolbar-mail-frame) + (if (cdr (frame-list)) + (delete-frame toolbar-mail-frame)) + (setq toolbar-mail-frame nil)))) + (add-hook 'mew-quit-hook + (lambda () + (when (frame-live-p toolbar-mail-frame) + (if (cdr (frame-list)) + (delete-frame toolbar-mail-frame)) + (setq toolbar-mail-frame nil)))) + (select-frame toolbar-mail-frame) + (mew)) + (when (framep toolbar-mail-frame) + (when (frame-iconified-p toolbar-mail-frame) + (deiconify-frame toolbar-mail-frame)) + (select-frame toolbar-mail-frame) + (raise-frame toolbar-mail-frame)))) + +;;; Copyright Notice: + +;; Copyright (C) 1999 Mew developing team. +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. Neither the name of the team nor the names of its contributors +;; may be used to endorse or promote products derived from this software +;; without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE +;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; mew-toolbar-frame.el ends here