;;; wl-folder.el -- Folder mode for Wanderlust.
-;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 1998,1999,2000 Masahiro MURATA <muse@ba2.so-net.ne.jp>
;; Author: Yuuichi Teranishi <teranisi@gohome.org>
+;; Masahiro MURATA <muse@ba2.so-net.ne.jp>
;; Keywords: mail, net news
;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
;;
;;; Commentary:
-;;
+;;
;;; Code:
-;;
+;;
(require 'elmo-vars)
(require 'elmo-util)
(defvar wl-folder-mode-map nil)
-(defvar wl-folder-opened-glyph nil)
-(defvar wl-folder-closed-glyph nil)
-(defvar wl-folder-nntp-glyph nil)
-(defvar wl-folder-imap4-glyph nil)
-(defvar wl-folder-pop3-glyph nil)
-(defvar wl-folder-localdir-glyph nil)
-(defvar wl-folder-localnews-glyph nil)
-(defvar wl-folder-internal-glyph nil)
-(defvar wl-folder-multi-glyph nil)
-(defvar wl-folder-filter-glyph nil)
-(defvar wl-folder-archive-glyph nil)
-(defvar wl-folder-pipe-glyph nil)
-(defvar wl-folder-maildir-glyph nil)
-(defvar wl-folder-trash-empty-glyph nil)
-(defvar wl-folder-trash-glyph nil)
-(defvar wl-folder-draft-glyph nil)
-(defvar wl-folder-queue-glyph nil)
-
(defvar wl-folder-buffer-disp-summary nil)
-(make-variable-buffer-local 'wl-folder-buffer-disp-summary)
(defvar wl-folder-buffer-cur-entity-id nil)
-(make-variable-buffer-local 'wl-folder-buffer-cur-entity-id)
(defvar wl-folder-buffer-cur-path nil)
-(make-variable-buffer-local 'wl-folder-buffer-cur-entity-id)
(defvar wl-folder-buffer-cur-point nil)
+
+(make-variable-buffer-local 'wl-folder-buffer-disp-summary)
+(make-variable-buffer-local 'wl-folder-buffer-cur-entity-id)
+(make-variable-buffer-local 'wl-folder-buffer-cur-path)
(make-variable-buffer-local 'wl-folder-buffer-cur-point)
(defconst wl-folder-entity-regexp "^\\([ ]*\\)\\(\\[[\\+-]\\]\\)?\\([^\\[].+\\):[-*0-9]+/[-*0-9]+/[-*0-9]+")
(define-key wl-folder-mode-map 'button2 'wl-folder-click)
(define-key wl-folder-mode-map 'button4 'wl-folder-prev-entity)
(define-key wl-folder-mode-map 'button5 'wl-folder-next-entity)
- (define-key wl-folder-mode-map [(shift button4)]
+ (define-key wl-folder-mode-map [(shift button4)]
'wl-folder-prev-unread)
- (define-key wl-folder-mode-map [(shift button5)]
+ (define-key wl-folder-mode-map [(shift button5)]
'wl-folder-next-unread))
(if wl-on-nemacs
(defun wl-folder-setup-mouse ())
(define-key wl-folder-mode-map "g" 'wl-folder-goto-folder)
(define-key wl-folder-mode-map "j" 'wl-folder-jump-to-current-entity)
(define-key wl-folder-mode-map "w" 'wl-draft)
- (define-key wl-folder-mode-map "W" 'wl-folder-write-current-newsgroup)
+ (define-key wl-folder-mode-map "W" 'wl-folder-write-current-folder)
(define-key wl-folder-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer)
(define-key wl-folder-mode-map "rS" 'wl-folder-sync-region)
(define-key wl-folder-mode-map "S" 'wl-folder-sync-current-entity)
(define-key wl-folder-mode-map "E" 'wl-folder-empty-trash)
(define-key wl-folder-mode-map "F" 'wl-folder-flush-queue)
(define-key wl-folder-mode-map "q" 'wl-exit)
- (define-key wl-folder-mode-map "z" 'wl-folder-suspend)
+ (define-key wl-folder-mode-map "z" 'wl-folder-suspend)
(define-key wl-folder-mode-map "\M-t" 'wl-toggle-plugged)
(define-key wl-folder-mode-map "\C-t" 'wl-plugged-change)
(define-key wl-folder-mode-map "<" 'beginning-of-buffer)
(define-key wl-folder-mode-map "\C-x\C-s" 'wl-save)
(define-key wl-folder-mode-map "\M-s" 'wl-save)
(define-key wl-folder-mode-map "\C-xk" 'wl-folder-mimic-kill-buffer)
+ (define-key wl-folder-mode-map "\M-\C-a"
+ 'wl-folder-goto-top-of-current-folder)
+ (define-key wl-folder-mode-map "\M-\C-e"
+ 'wl-folder-goto-bottom-of-current-folder)
+
(wl-folder-setup-mouse)
(easy-menu-define
wl-folder-mode-menu
(defun wl-folder-buffer-search-group (group)
(re-search-forward
- (concat
+ (concat
"^\\([ \t]*\\)\\[[\\+-]\\]"
(regexp-quote group) ":[-0-9-]+/[0-9-]+/[0-9-]+") nil t))
(defun wl-folder-buffer-search-entity (folder &optional searchname)
(let ((search (or searchname (wl-folder-get-petname folder))))
(re-search-forward
- (concat
+ (concat
"^[ \t]*"
(regexp-quote search) ":[-0-9\\*-]+/[0-9\\*-]+/[0-9\\*-]+") nil t)))
(goto-char (point-min))))
(defun wl-folder-next-entity-skip-invalid (&optional hereto)
- "move to next entity. skip unsubscribed or removed entity."
+ "Move to next entity. skip unsubscribed or removed entity."
(interactive)
(beginning-of-line)
(if (not hereto)
(setq entity (wl-pop entities))
(cond
((consp entity)
-;; (if (and (string= name (car entity))
-;; (eq id (wl-folder-get-entity-id (car entity))))
-;; (throw 'done last-entity))
+;; (if (and (string= name (car entity))
+;; (eq id (wl-folder-get-entity-id (car entity))))
+;; (throw 'done last-entity))
(and entities
(wl-push entities entity-stack))
(setq entities (nth 2 entity)))
(setq entity (wl-pop entities))
(cond
((consp entity)
-;; (if (and (string= name (car entity))
-;; (eq id (wl-folder-get-entity-id (car entity))))
-;; (setq found t))
+;;; (if (and (string= name (car entity))
+;;; (eq id (wl-folder-get-entity-id (car entity))))
+;;; (setq found t))
(and entities
(wl-push entities entity-stack))
(setq entities (nth 2 entity)))
(if (not (elmo-list-folder wl-queue-folder))
(message "No sending queue exists.")
(if wl-stay-folder-window
- (wl-folder-select-buffer
+ (wl-folder-select-buffer
(wl-summary-get-buffer-create wl-queue-folder)))
(wl-summary-goto-folder-subr wl-queue-folder 'force-update nil)
(unwind-protect
(wl-auto-select-first nil)
trash-buf emptied)
(if wl-stay-folder-window
- (wl-folder-select-buffer
+ (wl-folder-select-buffer
(wl-summary-get-buffer-create wl-trash-folder)))
(wl-summary-goto-folder-subr wl-trash-folder 'force-update nil nil t)
(setq trash-buf (current-buffer))
(if wl-stay-folder-window
(wl-folder-toggle-disp-summary 'off wl-trash-folder)
(switch-to-buffer cur-buf))
- (and trash-buf
+ (and trash-buf
(kill-buffer trash-buf)))))
-(defun wl-folder-goto-top-of-current-folder ()
- (if (re-search-backward "^\\([ ]*\\)\\[\\([\\+-]\\)\\]\\(.+\\)\n" nil t)
+(defun wl-folder-goto-top-of-current-folder (&optional arg)
+ "Move backward to the top of the current folder group.
+Optional argument ARG is repeart count."
+ (interactive "P")
+ (if (re-search-backward
+ "^ *\\[[\\+-]\\]" nil t (if arg (prefix-numeric-value arg)))
(beginning-of-line)
(goto-char (point-min))))
(defun wl-folder-goto-bottom-of-current-folder (indent)
+ "Move forward to the bottom of the current folder group."
+ (interactive
+ (let ((indent
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at "^ *")
+ (buffer-substring (match-beginning 0)(1- (match-end 0)))
+ ""))))
+ (list indent)))
(if (catch 'done
- (while (re-search-forward "^\\([ ]*\\)[^ ]" nil t)
- (if (<= (length (wl-match-buffer 1))
+ (while (re-search-forward "^ *" nil t)
+ (if (<= (length (match-string 0))
(length indent))
(throw 'done nil)))
(throw 'done t))
(goto-char (point-max))))
(defsubst wl-folder-update-group (entity diffs &optional is-group)
- (let ((path (wl-folder-get-path
+ (let ((path (wl-folder-get-path
wl-folder-entity
(wl-folder-get-entity-id entity)
entity)))
wl-force-fetch-folders)))
(defun wl-folder-jump-to-current-entity (&optional arg)
- "Enter the current folder. If optional arg exists, update folder list. "
+ "Enter the current folder. If optional ARG exists, update folder list."
(interactive "P")
(beginning-of-line)
(let (entity beg end indent opened fname err fld-name)
- (cond
+ (cond
((looking-at wl-folder-group-regexp)
(save-excursion
(setq fname (wl-folder-get-realname (wl-match-buffer 3)))
(setq opened (wl-match-buffer 2))
(if (string= opened "+")
(progn
- (setq entity (wl-folder-search-group-entity-by-name
+ (setq entity (wl-folder-search-group-entity-by-name
fname
wl-folder-entity))
(setq beg (point))
(quit
(setq err t)
(setcdr (assoc fname wl-folder-group-alist) nil))
- (error
+ (error
(elmo-display-error errobj t)
(ding)
(setq err t)
(progn (wl-folder-goto-bottom-of-current-folder indent)
(beginning-of-line)
(point))))
- (setq entity (wl-folder-search-group-entity-by-name
+ (setq entity (wl-folder-search-group-entity-by-name
fname
wl-folder-entity))
(let ((buffer-read-only nil))
((setq fld-name (wl-folder-entity-name))
(if wl-on-nemacs
(progn
- (wl-folder-set-current-entity-id
+ (wl-folder-set-current-entity-id
(wl-folder-get-entity-from-buffer))
(setq fld-name (wl-folder-get-realname fld-name)))
- (wl-folder-set-current-entity-id
+ (wl-folder-set-current-entity-id
(get-text-property (point) 'wl-folder-entity-id))
(setq fld-name (wl-folder-get-folder-name-by-id
wl-folder-buffer-cur-entity-id)))
(if (and summary-buf
(get-buffer-window summary-buf))
(delete-window)))
- (wl-summary-goto-folder-subr fld-name
+ (wl-summary-goto-folder-subr fld-name
(wl-summary-get-sync-range fld-name)
nil arg t)))))
(set-buffer-modified-p nil))
(cond
((string= (wl-match-buffer 2) "+")
(save-excursion
- (if entity ()
- (setq entity
- (wl-folder-search-group-entity-by-name
- (wl-folder-get-realname (wl-match-buffer 3))
- wl-folder-entity)))
- (let ((inhibit-read-only t)
- (entities (list entity))
- entity-stack err indent)
- (while (and entities (not err))
- (setq entity (wl-pop entities))
- (cond
- ((consp entity)
- (wl-folder-close-entity entity)
- (setcdr (assoc (car entity) wl-folder-group-alist) t)
- (unless (wl-folder-buffer-search-group
- (wl-folder-get-petname (car entity)))
- (error "%s: not found group" (car entity)))
- (setq indent (wl-match-buffer 1))
- (if (eq 'access (cadr entity))
- (wl-folder-maybe-load-folder-list entity))
- (beginning-of-line)
- (setq err nil)
- (save-excursion
- (condition-case errobj
- (wl-folder-update-newest indent entity)
- (quit
- (setq err t)
- (setcdr (assoc (car entity) wl-folder-group-alist) nil))
- (error
- (elmo-display-error errobj t)
- (ding)
- (setq err t)
- (setcdr (assoc (car entity) wl-folder-group-alist) nil)))
- (if (not err)
- (delete-region (save-excursion (beginning-of-line)
- (point))
- (save-excursion (end-of-line)
- (+ 1 (point))))))
- ;;
- (and entities
- (wl-push entities entity-stack))
- (setq entities (nth 2 entity))))
- (unless entities
- (setq entities (wl-pop entity-stack)))))
+ (if entity ()
+ (setq entity
+ (wl-folder-search-group-entity-by-name
+ (wl-folder-get-realname (wl-match-buffer 3))
+ wl-folder-entity)))
+ (let ((inhibit-read-only t)
+ (entities (list entity))
+ entity-stack err indent)
+ (while (and entities (not err))
+ (setq entity (wl-pop entities))
+ (cond
+ ((consp entity)
+ (wl-folder-close-entity entity)
+ (setcdr (assoc (car entity) wl-folder-group-alist) t)
+ (unless (wl-folder-buffer-search-group
+ (wl-folder-get-petname (car entity)))
+ (error "%s: not found group" (car entity)))
+ (setq indent (wl-match-buffer 1))
+ (if (eq 'access (cadr entity))
+ (wl-folder-maybe-load-folder-list entity))
+ (beginning-of-line)
+ (setq err nil)
+ (save-excursion
+ (condition-case errobj
+ (wl-folder-update-newest indent entity)
+ (quit
+ (setq err t)
+ (setcdr (assoc (car entity) wl-folder-group-alist) nil))
+ (error
+ (elmo-display-error errobj t)
+ (ding)
+ (setq err t)
+ (setcdr (assoc (car entity) wl-folder-group-alist) nil)))
+ (if (not err)
+ (delete-region (save-excursion (beginning-of-line)
+ (point))
+ (save-excursion (end-of-line)
+ (+ 1 (point))))))
+ ;;
+ (and entities
+ (wl-push entities entity-stack))
+ (setq entities (nth 2 entity))))
+ (unless entities
+ (setq entities (wl-pop entity-stack)))))
(set-buffer-modified-p nil)))
(t
(wl-folder-jump-to-current-entity)))))
(save-excursion
(cond
((consp entity)
- (let ((flist (if auto
+ (let ((flist (if auto
(elmo-delete-if
'wl-folder-no-auto-check-folder-p
(nth 2 entity))
(t
(message "Uncheck(unplugged) \"%s\"" entity)))))
(if ret-val
- (message "Checking \"%s\" is done."
+ (message "Checking \"%s\" is done."
(if (consp entity) (car entity) entity)))
(run-hooks 'wl-folder-check-entity-hook)
ret-val))
-;; All contained folders are imap4 and persistent flag, then
+;; All contained folders are imap4 and persistent flag, then
;; use server diff.
(defun wl-folder-use-server-diff-p (folder)
(let ((spec (elmo-folder-get-spec folder)))
(defun wl-folder-check-one-entity (entity)
(let* ((elmo-use-server-diff (wl-folder-use-server-diff-p entity))
(nums (condition-case err
- (if (wl-string-member entity wl-strict-diff-folders)
+ (if (wl-string-match-member entity wl-strict-diff-folders)
(elmo-strict-folder-diff entity)
(elmo-folder-diff entity))
(error
;; maybe not exist folder.
- (if (not (elmo-folder-exists-p entity))
- (if (not (elmo-folder-creatable-p entity))
- (error "Folder %s is not found" entity)
- (if (y-or-n-p
- (format "Folder %s does not exist, create it?"
- entity))
- (progn
- (unless (elmo-create-folder entity)
- (error "Create folder failed"))
- ;; one more try.
- (if (wl-string-member entity wl-strict-diff-folders)
- (elmo-strict-folder-diff entity)
- (elmo-folder-diff entity)))
- (error "Folder is not created")))
+ (if (and (not (memq 'elmo-open-error
+ (get (car err) 'error-conditions)))
+ (not (elmo-folder-exists-p entity)))
+ (wl-folder-create-subr entity)
(signal (car err) (cdr err))))))
unread unsync nomif)
(if (and (eq wl-folder-notify-deleted 'sync)
(setq nums (cons unsync nomif)))
(wl-folder-entity-hashtb-set wl-folder-entity-hashtb entity
(list (car nums)
- (setq
+ (setq
unread
- (or
+ (or
;; If server diff, All unreads are
;; treated as unsync.
(if elmo-use-server-diff 0)
(elmo-msgdb-expand-path entity))
entity)))
(cdr nums))
- (current-buffer)))
+ (get-buffer wl-folder-buffer-name)))
(setq wl-folder-info-alist-modified t)
(sit-for 0)
(list (if wl-folder-notify-deleted
(wl-append net-elist (list (car elist)))
(while spec-list
(when (eq (caar spec-list) 'nntp)
- (when (not (string= server (nth 2 (car spec-list))))
- (setq server (nth 2 (car spec-list)))
+ (when (not (string= server (elmo-nntp-spec-hostname (car spec-list))))
+ (setq server (elmo-nntp-spec-hostname (car spec-list)))
(message "Checking on \"%s\"" server))
(setq nntp-connection-keys
(elmo-nntp-get-folders-info-prepare
(defun wl-folder-set-current-entity-id (entity-id)
(let ((buf (get-buffer wl-folder-buffer-name)))
(if buf
- (save-excursion
+ (save-excursion
(set-buffer buf)
(setq wl-folder-buffer-cur-entity-id entity-id)
(setq wl-folder-buffer-cur-path (wl-folder-get-path wl-folder-entity
(goto-char wl-folder-buffer-cur-point)))))
(defun wl-folder-check-current-entity ()
- "Check folder at position.
+ "Check folder at position.
If current line is group folder, check all sub entries."
(interactive)
(let* ((entity-name (wl-folder-get-entity-from-buffer))
(setq unread (or (cadr nums) 0))
(if (or (not unread-only)
(or (< 0 new) (< 0 unread)))
- (save-window-excursion
- (save-excursion
- (wl-summary-goto-folder-subr entity
- (wl-summary-get-sync-range entity)
- nil nil nil t)
- (wl-summary-exit))))))))
+ (let ((wl-summary-buffer-name (concat
+ wl-summary-buffer-name
+ (symbol-name this-command)))
+ (wl-message-buf-name (concat wl-message-buf-name
+ (symbol-name this-command))))
+ (save-window-excursion
+ (save-excursion
+ (wl-summary-goto-folder-subr entity
+ (wl-summary-get-sync-range entity)
+ nil nil nil t)
+ (wl-summary-exit)))))))))
(defun wl-folder-sync-current-entity (&optional unread-only)
- "Synchronize the folder at position.
+ "Synchronize the folder at position.
If current line is group folder, check all subfolders."
(interactive "P")
(save-excursion
(message "Syncing %s is done!" entity-name)))))
(defun wl-folder-mark-as-read-all-entity (entity)
- "Mark as read all messages in the ENTITY"
+ "Mark as read all messages in the ENTITY."
(cond
((consp entity)
(let ((flist (nth 2 entity)))
(setq new (or (car nums) 0))
(setq unread (or (cadr nums) 0))
(if (or (< 0 new) (< 0 unread))
- (save-window-excursion
- (save-excursion
- (wl-summary-goto-folder-subr entity
- (wl-summary-get-sync-range entity)
- nil)
- (wl-summary-mark-as-read-all)
- (wl-summary-exit)))
+ (let ((wl-summary-buffer-name (concat
+ wl-summary-buffer-name
+ (symbol-name this-command)))
+ (wl-message-buf-name (concat wl-message-buf-name
+ (symbol-name this-command))))
+ (save-window-excursion
+ (save-excursion
+ (wl-summary-goto-folder-subr entity
+ (wl-summary-get-sync-range entity)
+ nil)
+ (wl-summary-mark-as-read-all)
+ (wl-summary-exit))))
(sit-for 0))))))
(defun wl-folder-mark-as-read-all-current-entity ()
- "Mark as read all messages in the folder at position.
+ "Mark as read all messages in the folder at position.
If current line is group folder, all subfolders are marked."
(interactive)
(save-excursion
entity)
(while (< (point) end)
;; normal folder entity
- (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
+ (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
(save-excursion
(setq entity (wl-folder-get-entity-from-buffer))
(if (not (elmo-folder-plugged-p entity))
(goto-char beg)
(while (< (point) end)
;; normal folder entity
- (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
+ (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
(save-excursion
(let ((inhibit-read-only t)
entity)
(goto-char beg)
(while (< (point) end)
;; normal folder entity
- (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
+ (if (looking-at "^[\t ]*\\([^\\[]+\\):\\(.*\\)\n")
(save-excursion
(let ((inhibit-read-only t)
entity)
(while (setq entity (wl-create-folder-entity-from-buffer))
(unless (eq entity 'ignore)
(wl-append flist (list entity))))
- (if (looking-at "^[\t ]*}[\t ]*$") ; end of group
+ (if (looking-at "^[\t ]*}[\t ]*$") ; end of group
(progn
(goto-char (+ 1 (match-end 0)))
(if (wl-string-assoc name wl-folder-petname-alist)
;; (setq flist (car flist))
;; (list name 'access flist unsublist)))
(append (list name 'access) (wl-create-access-folder-entity name))))
- ;((looking-at "^[\t ]*\\([^\t \n}]+\\)[\t ]*\\(\"[^\"]*\"\\)?[\t ]*$") ; normal folder entity
+ ;((looking-at "^[\t ]*\\([^\t \n}]+\\)[\t ]*\\(\"[^\"]*\"\\)?[\t ]*$") ; normal folder entity
((looking-at "^[\t ]*=[ \t]+\\([^\n]+\\)$"); petname definition
(goto-char (+ 1 (match-end 0)))
(let ((rest (elmo-match-buffer 1))
entity ret-val)
(condition-case ()
(progn
- (set-buffer tmp-buf)
- (erase-buffer)
- (insert-file-contents wl-folders-file)
- (goto-char (point-min))
- (while (and (not (eobp))
- (setq entity (wl-create-folder-entity-from-buffer)))
- (unless (eq entity 'ignore)
- (wl-append ret-val (list entity))))
+ (with-current-buffer tmp-buf
+ (erase-buffer)
+ (insert-file-contents wl-folders-file)
+ (goto-char (point-min))
+ (while (and (not (eobp))
+ (setq entity (wl-create-folder-entity-from-buffer)))
+ (unless (eq entity 'ignore)
+ (wl-append ret-val (list entity)))))
(kill-buffer tmp-buf))
(file-error nil))
(setq ret-val (list wl-folder-desktop-name 'group ret-val))))
(defun wl-folder-entity-assign-id (entity &optional hashtb on-noid)
- (let* ((hashtb (or hashtb
- (setq wl-folder-entity-id-name-hashtb
- (elmo-make-hash wl-folder-entity-id))))
- (entities (list entity))
- entity-stack)
+ (let ((hashtb (or hashtb
+ (setq wl-folder-entity-id-name-hashtb
+ (elmo-make-hash wl-folder-entity-id))))
+ (entities (list entity))
+ entity-stack)
(while entities
(setq entity (wl-pop entities))
(cond
'wl-folder-entity-id
(car entity))))
(put-text-property 0 (length (car entity))
- 'wl-folder-entity-id
+ 'wl-folder-entity-id
wl-folder-entity-id
(car entity))
(wl-folder-set-id-name wl-folder-entity-id
(get-text-property 0
'wl-folder-entity-id
entity)))
- (put-text-property 0 (length entity)
- 'wl-folder-entity-id
+ (put-text-property 0 (length entity)
+ 'wl-folder-entity-id
wl-folder-entity-id
entity)
(wl-folder-set-id-name wl-folder-entity-id
(defun wl-folder-select-buffer (buffer)
(let ((gbw (get-buffer-window buffer))
- ret-val)
+ exists)
(if gbw
(progn (select-window gbw)
- (setq ret-val t))
- (condition-case ()
- (unwind-protect
- (split-window-horizontally wl-folder-window-width)
- (other-window 1))
- (error nil)))
+ (setq exists t))
+ (unless wl-folder-use-frame
+ (condition-case ()
+ (unwind-protect
+ (split-window-horizontally wl-folder-window-width)
+ (other-window 1))
+ (error nil))))
(set-buffer buffer)
- (switch-to-buffer buffer)
- ret-val
- ))
+ (if wl-folder-use-frame
+ (switch-to-buffer-other-frame buffer)
+ (switch-to-buffer buffer))
+ exists))
(defun wl-folder-toggle-disp-summary (&optional arg folder)
(interactive)
(delete-window)
(select-window (get-buffer-window cur-buf))))
(t
- (setq wl-folder-buffer-disp-summary
+ (setq wl-folder-buffer-disp-summary
(not wl-folder-buffer-disp-summary))
(let ((cur-buf (current-buffer))
folder-name)
(setq folder-name (wl-folder-get-entity-from-buffer))
(if wl-folder-buffer-disp-summary
(progn
- (wl-folder-select-buffer
+ (wl-folder-select-buffer
(wl-summary-get-buffer-create folder-name))
(unwind-protect
(wl-summary-goto-folder-subr folder-name 'no-sync nil)
(select-window (get-buffer-window cur-buf)))))))))
(defun wl-folder-prev-unsync ()
- "move cursor to the previous unsync folder."
+ "Move cursor to the previous unsync folder."
(interactive)
(let (start-point)
(setq start-point (point))
(message "No more unsync folder"))))
(defun wl-folder-next-unsync (&optional plugged)
- "move cursor to the next unsync."
+ "Move cursor to the next unsync."
(interactive)
(let (start-point entity)
(setq start-point (point))
(message "No more unsync folder"))))
(defun wl-folder-prev-unread (&optional group)
- "move cursor to the previous unread folder."
+ "Move cursor to the previous unread folder."
(interactive "P")
(let (start-point)
(setq start-point (point))
nil)))
(defun wl-folder-next-unread (&optional group)
- "move cursor to the next unread folder."
+ "Move cursor to the next unread folder."
(interactive "P")
(let (start-point)
(setq start-point (point))
(defun wl-folder-mode ()
"Major mode for Wanderlust Folder.
-See info under Wanderlust for full documentation.
+See Info under Wanderlust for full documentation.
Special commands:
\\{wl-folder-mode-map}
(setq buffer-read-only t)
(setq inhibit-read-only nil)
(setq truncate-lines t)
- (when wl-show-plug-status-on-modeline
- (setq mode-line-format (wl-make-modeline)))
+ (setq wl-folder-buffer-cur-entity-id nil
+ wl-folder-buffer-cur-path nil
+ wl-folder-buffer-cur-point nil)
+ (wl-mode-line-buffer-identification)
(easy-menu-add wl-folder-mode-menu)
- (wl-xmas-setup-folder)
+ ;; This hook may contain the functions `wl-folder-init-icons' and
+ ;; `wl-setup-folder' for reasons of system internal to accord
+ ;; facilities for the Emacs variants.
(run-hooks 'wl-folder-mode-hook))
(defun wl-folder-append-petname (realname petname)
(defun wl-folder (&optional arg)
(interactive "P")
(let (initialize)
-; (delete-other-windows)
- (if (get-buffer wl-folder-buffer-name)
- (switch-to-buffer wl-folder-buffer-name)
- (switch-to-buffer (get-buffer-create wl-folder-buffer-name))
- (setq mode-line-buffer-identification '("Wanderlust: %12b"))
- (wl-folder-mode)
- (wl-folder-init)
- (wl-folder-init-icons)
- (set-buffer wl-folder-buffer-name)
- (let ((inhibit-read-only t)
- (buffer-read-only nil))
- (erase-buffer)
- (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
- (save-excursion
- (wl-folder-insert-entity " " wl-folder-entity)))
- (set-buffer-modified-p nil)
- (sit-for 0)
- (setq initialize t))
- (if (not arg)
- (progn
- (run-hooks 'wl-auto-check-folder-pre-hook)
- (cond
- ((eq wl-auto-check-folder-name 'none))
- ((or (consp wl-auto-check-folder-name)
- (stringp wl-auto-check-folder-name))
- (let ((folder-list (if (consp wl-auto-check-folder-name)
- wl-auto-check-folder-name
- (list wl-auto-check-folder-name)))
- entity)
- (while folder-list
- (if (setq entity (wl-folder-search-entity-by-name
- (car folder-list)
- wl-folder-entity))
- (wl-folder-check-entity entity 'auto))
- (setq folder-list (cdr folder-list)))))
- (t
- (wl-folder-check-entity wl-folder-entity 'auto)))
- (run-hooks 'wl-auto-check-folder-hook)))
- initialize))
+;;; (delete-other-windows)
+ (if (get-buffer wl-folder-buffer-name)
+ (switch-to-buffer wl-folder-buffer-name)
+ (switch-to-buffer (get-buffer-create wl-folder-buffer-name))
+ (wl-folder-mode)
+ (wl-folder-init)
+ (set-buffer wl-folder-buffer-name)
+ (let ((inhibit-read-only t)
+ (buffer-read-only nil))
+ (erase-buffer)
+ (setcdr (assoc (car wl-folder-entity) wl-folder-group-alist) t)
+ (save-excursion
+ (wl-folder-insert-entity " " wl-folder-entity)))
+ (set-buffer-modified-p nil)
+ ;(sit-for 0)
+ (setq initialize t))
+ initialize))
+
+(defun wl-folder-auto-check ()
+ "Check and update folders in `wl-auto-check-folder-name'."
+ (interactive)
+ (when (get-buffer wl-folder-buffer-name)
+ (switch-to-buffer wl-folder-buffer-name)
+ (cond
+ ((eq wl-auto-check-folder-name 'none))
+ ((or (consp wl-auto-check-folder-name)
+ (stringp wl-auto-check-folder-name))
+ (let ((folder-list (if (consp wl-auto-check-folder-name)
+ wl-auto-check-folder-name
+ (list wl-auto-check-folder-name)))
+ entity)
+ (while folder-list
+ (if (setq entity (wl-folder-search-entity-by-name
+ (car folder-list)
+ wl-folder-entity))
+ (wl-folder-check-entity entity 'auto))
+ (setq folder-list (cdr folder-list)))))
+ (t
+ (wl-folder-check-entity wl-folder-entity 'auto)))))
(defun wl-folder-set-folder-updated (name value)
(save-excursion
(let (buf)
(if (setq buf (get-buffer wl-folder-buffer-name))
- (wl-folder-entity-hashtb-set
+ (wl-folder-entity-hashtb-set
wl-folder-entity-hashtb name value buf))
-;; (elmo-folder-set-info-hashtb (elmo-string name)
-;; nil
-;; (nth 2 value)
-;; (nth 0 value)
-;; (nth 1 value))
+;;; (elmo-folder-set-info-hashtb (elmo-string name)
+;;; nil
+;;; (nth 2 value)
+;;; (nth 0 value)
+;;; (nth 1 value))
(setq wl-folder-info-alist-modified t))))
(defun wl-folder-calc-finfo (entity)
(defun wl-folder-update-newest (indent entity)
(let (ret-val new unread all)
- (cond
+ (cond
((consp entity)
(let ((inhibit-read-only t)
(buffer-read-only nil)
(setq flist-unsub (nth 2 update-flist))
(setq removed (nth 3 update-flist))
(elmo-msgdb-flist-save
- (car entity)
+ (car entity)
(list
(wl-folder-make-save-access-list flist)
(wl-folder-make-save-access-list flist-unsub)))
(wl-folder-create-newsgroups-hashtb
entity nil)
wl-folder-newsgroups-hashtb))))
- (message "Fetching folder entries...done."))
+ (message "Fetching folder entries...done"))
(wl-folder-insert-entity indent entity))))))))
(defun wl-folder-insert-entity (indent entity &optional onlygroup)
(let (ret-val new unread all)
- (cond
+ (cond
((consp entity)
(let ((inhibit-read-only t)
(buffer-read-only nil)
(as-opened (cdr (assoc (car entity) wl-folder-group-alist)))
beg
)
-; (insert indent "[" (if as-opened "-" "+") "]" (car entity) "\n")
-; (save-excursion (forward-line -1)
-; (wl-highlight-folder-current-line))
+;;; (insert indent "[" (if as-opened "-" "+") "]" (car entity) "\n")
+;;; (save-excursion (forward-line -1)
+;;; (wl-highlight-folder-current-line))
(setq beg (point))
(if (and as-opened
(not onlygroup))
(let (update-flist flist-unsub new-flist removed group-name-end)
-; (when (and (eq (cadr entity) 'access)
-; newest)
-; (message "fetching folder entries...")
-; (when (setq new-flist
-; (elmo-list-folders
-; (elmo-string (car entity))
-; (wl-string-member
-; (car entity)
-; wl-folder-hierarchy-access-folders)
-; ))
-; (setq update-flist
-; (wl-folder-update-access-group entity new-flist))
-; (setq flist (nth 1 update-flist))
-; (when (car update-flist) ;; diff
-; (setq flist-unsub (nth 2 update-flist))
-; (setq removed (nth 3 update-flist))
-; (elmo-msgdb-flist-save
-; (car entity)
-; (list
-; (wl-folder-make-save-access-list flist)
-; (wl-folder-make-save-access-list flist-unsub)))
-; ;;
-; ;; reconstruct wl-folder-entity-id-name-hashtb and
-; ;; wl-folder-entity-hashtb
-; ;;
-; (wl-folder-entity-assign-id
-; entity
-; wl-folder-entity-id-name-hashtb
-; t)
-; (setq wl-folder-entity-hashtb
-; (wl-folder-create-entity-hashtb
-; entity
-; wl-folder-entity-hashtb
-; t))
-; (setq wl-folder-newsgroups-hashtb
-; (or
-; (wl-folder-create-newsgroups-hashtb
-; entity nil)
-; wl-folder-newsgroups-hashtb))))
-; (message "fetching folder entries...done."))
- (insert indent "[" (if as-opened "-" "+") "]"
+;;; (when (and (eq (cadr entity) 'access)
+;;; newest)
+;;; (message "fetching folder entries...")
+;;; (when (setq new-flist
+;;; (elmo-list-folders
+;;; (elmo-string (car entity))
+;;; (wl-string-member
+;;; (car entity)
+;;; wl-folder-hierarchy-access-folders)
+;;; ))
+;;; (setq update-flist
+;;; (wl-folder-update-access-group entity new-flist))
+;;; (setq flist (nth 1 update-flist))
+;;; (when (car update-flist) ;; diff
+;;; (setq flist-unsub (nth 2 update-flist))
+;;; (setq removed (nth 3 update-flist))
+;;; (elmo-msgdb-flist-save
+;;; (car entity)
+;;; (list
+;;; (wl-folder-make-save-access-list flist)
+;;; (wl-folder-make-save-access-list flist-unsub)))
+;;; ;;
+;;; ;; reconstruct wl-folder-entity-id-name-hashtb and
+;;; ;; wl-folder-entity-hashtb
+;;; ;;
+;;; (wl-folder-entity-assign-id
+;;; entity
+;;; wl-folder-entity-id-name-hashtb
+;;; t)
+;;; (setq wl-folder-entity-hashtb
+;;; (wl-folder-create-entity-hashtb
+;;; entity
+;;; wl-folder-entity-hashtb
+;;; t))
+;;; (setq wl-folder-newsgroups-hashtb
+;;; (or
+;;; (wl-folder-create-newsgroups-hashtb
+;;; entity nil)
+;;; wl-folder-newsgroups-hashtb))))
+;;; (message "fetching folder entries...done"))
+ (insert indent "[" (if as-opened "-" "+") "]"
(wl-folder-get-petname (car entity)))
(setq group-name-end (point))
(insert ":0/0/0\n")
(put-text-property beg (point) 'wl-folder-entity-id
- (get-text-property 0 'wl-folder-entity-id
+ (get-text-property 0 'wl-folder-entity-id
(car entity)))
(when removed
(setq beg (point))
(while removed
- (insert indent " "
+ (insert indent " "
wl-folder-removed-mark
(if (listp (car removed))
(concat "[+]" (caar removed))
(i 0))
(while flist
(setq ret-val
- (wl-folder-insert-entity
+ (wl-folder-insert-entity
(concat indent " ") (car flist)))
(setq new (+ (or new 0) (or (nth 0 ret-val) 0)))
(setq unread (+ (or unread 0) (or (nth 1 ret-val) 0)))
(setq all (+ (or all 0) (or (nth 2 ret-val) 0)))
- (when mes
+ (when (and mes
+ (> len elmo-display-progress-threshold))
(setq i (1+ i))
(elmo-display-progress
'wl-folder-insert-entity "Inserting group %s..."
(/ (* i 100) len) (car entity)))
- (setq flist (cdr flist)))
- (when mes
- (elmo-display-progress
- 'wl-folder-insert-entity "Inserting group %s..."
- 100 (car entity))))
+ (setq flist (cdr flist))))
(save-excursion
(goto-char group-name-end)
(delete-region (point) (save-excursion (end-of-line)
(setq ret-val (list new unread all))
(wl-highlight-folder-current-line ret-val)))
(setq ret-val (wl-folder-calc-finfo entity))
- (insert indent "[" (if as-opened "-" "+") "]"
- (wl-folder-get-petname (car entity))
- (format ":%d/%d/%d"
+ (insert indent "[" (if as-opened "-" "+") "]"
+ (wl-folder-get-petname (car entity))
+ (format ":%d/%d/%d"
(or (nth 0 ret-val) 0)
(or (nth 1 ret-val) 0)
(or (nth 2 ret-val) 0))
"\n")
(put-text-property beg (point) 'wl-folder-entity-id
- (get-text-property 0 'wl-folder-entity-id
+ (get-text-property 0 'wl-folder-entity-id
(car entity)))
(save-excursion (forward-line -1)
(wl-highlight-folder-current-line ret-val)))))
beg)
(setq beg (point))
(insert indent (wl-folder-get-petname entity)
- (format ":%s/%s/%s\n"
+ (format ":%s/%s/%s\n"
(or (setq new (nth 0 nums)) "*")
(or (setq unread (and (nth 0 nums)(nth 1 nums)
(+ (nth 0 nums)(nth 1 nums))))
(wl-folder-check-entity wl-folder-entity))
(defun wl-folder-entity-hashtb-set (entity-hashtb name value buffer)
- (let (cur-val
+ (let (cur-val
(new-diff 0)
(unread-diff 0)
(all-diff 0)
entity-list)
(setq cur-val (wl-folder-get-entity-info name entity-hashtb))
(setq new-diff (- (or (nth 0 value) 0) (or (nth 0 cur-val) 0)))
- (setq unread-diff
+ (setq unread-diff
(+ new-diff
(- (or (nth 1 value) 0) (or (nth 1 cur-val) 0))))
(setq all-diff (- (or (nth 2 value) 0) (or (nth 2 cur-val) 0)))
(unread-diff 0)
;;(fld (elmo-string folder))
value newvalue entity-list)
- ;; Update folder-info
- ;;(elmo-folder-set-info-hashtb fld nil nil nil unread)
+;;; Update folder-info
+;;; (elmo-folder-set-info-hashtb fld nil nil nil unread)
(setq cur-unread (or (nth 1 (wl-folder-get-entity-info folder)) 0))
(setq unread-diff (- (or unread 0) cur-unread))
(setq value (wl-folder-get-entity-info folder))
(wl-folder-update-line newvalue)))))))))
(defun wl-folder-create-entity-hashtb (entity &optional hashtb reconst)
- (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
- (entities (list entity))
- entity-stack)
+ (let ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
+ (entities (list entity))
+ entity-stack)
(while entities
(setq entity (wl-pop entities))
(cond
hashtb))
;; Unsync number is reserved.
-;; (defun wl-folder-reconstruct-entity-hashtb (entity &optional hashtb id-name)
-;; (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
-;; (entities (list entity))
-;; entity-stack)
-;; (while entities
-;; (setq entity (wl-pop entities))
-;; (cond
-;; ((consp entity)
-;; (if id-name
-;; (wl-folder-set-id-name (wl-folder-get-entity-id (car entity))
-;; (car entity)))
-;; (and entities
-;; (wl-push entities entity-stack))
-;; (setq entities (nth 2 entity))
-;; )
-;; ((stringp entity)
-;; (wl-folder-set-entity-info entity
-;; (wl-folder-get-entity-info entity)
-;; hashtb)
-;; (if id-name
-;; (wl-folder-set-id-name (wl-folder-get-entity-id entity)
-;; entity))))
-;; (unless entities
-;; (setq entities (wl-pop entity-stack))))
-;; hashtb))
+;;(defun wl-folder-reconstruct-entity-hashtb (entity &optional hashtb id-name)
+;; (let* ((hashtb (or hashtb (elmo-make-hash wl-folder-entity-id)))
+;; (entities (list entity))
+;; entity-stack)
+;; (while entities
+;; (setq entity (wl-pop entities))
+;; (cond
+;; ((consp entity)
+;; (if id-name
+;; (wl-folder-set-id-name (wl-folder-get-entity-id (car entity))
+;; (car entity)))
+;; (and entities
+;; (wl-push entities entity-stack))
+;; (setq entities (nth 2 entity))
+;; )
+;; ((stringp entity)
+;; (wl-folder-set-entity-info entity
+;; (wl-folder-get-entity-info entity)
+;; hashtb)
+;; (if id-name
+;; (wl-folder-set-id-name (wl-folder-get-entity-id entity)
+;; entity))))
+;; (unless entities
+;; (setq entities (wl-pop entity-stack))))
+;; hashtb))
(defun wl-folder-create-newsgroups-from-nntp-access2 (entity)
(let ((flist (nth 2 entity))
((consp entity)
(if (eq (nth 1 entity) 'access)
(when (eq (elmo-folder-get-type (car entity)) 'nntp)
- (wl-append folders
+ (wl-append folders
(wl-folder-create-newsgroups-from-nntp-access entity))
(setq make-hashtb t))
(and entities
(elmo-nntp-make-groups-hashtb folders))))
(defun wl-folder-get-path (entity target-id &optional string)
- (let* ((entities (list entity))
- entity-stack result-path)
+ (let ((entities (list entity))
+ entity-stack result-path)
(reverse
(catch 'done
(while entities
(defun wl-folder-create-group-alist (entity)
(if (consp entity)
- (let ((flist (nth 2 entity)) cur-alist append-alist)
- (setq cur-alist (list (cons (car entity) nil)))
+ (let ((flist (nth 2 entity))
+ (cur-alist (list (cons (car entity) nil)))
+ append-alist)
(while flist
(if (consp (car flist))
(wl-append append-alist
(elmo-folder-info-make-hashtb
info-alist
wl-folder-entity-hashtb)))
-;; (wl-folder-resume-entity-hashtb-by-finfo
-;; wl-folder-entity-hashtb
-;; info-alist)))
+;;; (wl-folder-resume-entity-hashtb-by-finfo
+;;; wl-folder-entity-hashtb
+;;; info-alist)))
(defun wl-folder-cleanup-variables ()
(setq wl-folder-entity nil
wl-nntp-posting-server
elmo-default-nntp-port
nil nil "nntp" add))
- (wl-plugged-init-icons)
- ;; user setting
(run-hooks 'wl-make-plugged-hook)))
(defvar wl-folder-init-func 'wl-local-folder-init)
(defun wl-folder-init ()
+ "Call `wl-folder-init-func' function."
(interactive)
(funcall wl-folder-init-func))
(defun wl-local-folder-init ()
+ "Initialize local folder."
(message "Initializing folder...")
(save-excursion
- (let* ((entity (wl-folder-create-folder-entity))
- (inhibit-read-only t))
+ (set-buffer wl-folder-buffer-name)
+ (let ((entity (wl-folder-create-folder-entity))
+ (inhibit-read-only t))
(setq wl-folder-entity entity)
(setq wl-folder-entity-id 0)
(wl-folder-entity-assign-id wl-folder-entity)
(wl-folder-create-group-alist entity))
(setq wl-folder-newsgroups-hashtb
(wl-folder-create-newsgroups-hashtb wl-folder-entity))
- (wl-folder-init-info-hashtb)
- (setq wl-folder-buffer-cur-entity-id nil
- wl-folder-buffer-cur-path nil
- wl-folder-buffer-cur-point nil)))
- (message "Initializing folder...done."))
+ (wl-folder-init-info-hashtb)))
+ (message "Initializing folder...done"))
(defun wl-folder-get-realname (petname)
- (or (car
- (wl-string-rassoc
+ (or (car
+ (wl-string-rassoc
petname
wl-folder-petname-alist))
petname))
(defun wl-folder-get-petname (folder)
- (or (cdr
- (wl-string-assoc
- folder
+ (or (cdr
+ (wl-string-assoc
+ folder
wl-folder-petname-alist))
folder))
(setq alist (cdr alist)))
hashtb))
+(defun wl-folder-get-newsgroups (folder)
+ "Return Newsgroups field value string for FOLDER newsgroup.
+If FOLDER is multi, return comma separated string (cross post)."
+ (let ((flist (elmo-folder-get-primitive-folder-list folder)) ; multi
+ newsgroups fld ret)
+ (while (setq fld (car flist))
+ (if (setq ret
+ (cond ((eq 'nntp (elmo-folder-get-type fld))
+ (nth 1 (elmo-folder-get-spec fld)))
+ ((eq 'localnews (elmo-folder-get-type fld))
+ (elmo-replace-in-string
+ (nth 1 (elmo-folder-get-spec fld)) "/" "\\."))))
+ ;; append newsgroup
+ (setq newsgroups (if (stringp newsgroups)
+ (concat newsgroups "," ret)
+ ret)))
+ (setq flist (cdr flist)))
+ (list nil nil newsgroups)))
+
+(defun wl-folder-guess-mailing-list-by-refile-rule (folder)
+ "Return ML address guess by FOLDER.
+Use `wl-subscribed-mailing-list' and `wl-refile-rule-alist'.
+Don't care multi."
+ (setq folder (car (elmo-folder-get-primitive-folder-list folder)))
+ (unless (memq (elmo-folder-get-type folder)
+ '(localnews nntp))
+ (let ((rules wl-refile-rule-alist)
+ mladdress tokey toalist histkey)
+ (while rules
+ (if (or (and (stringp (car (car rules)))
+ (string-match "[Tt]o" (car (car rules))))
+ (and (listp (car (car rules)))
+ (elmo-string-matched-member "to" (car (car rules))
+ 'case-ignore)))
+ (setq toalist (append toalist (cdr (car rules)))))
+ (setq rules (cdr rules)))
+ (setq tokey (car (rassoc folder toalist)))
+;;; (setq histkey (car (rassoc folder wl-refile-alist)))
+ ;; case-ignore search `wl-subscribed-mailing-list'
+ (if (stringp tokey)
+ (list
+ (elmo-string-matched-member tokey wl-subscribed-mailing-list t)
+ nil nil)
+ nil))))
+
+(defun wl-folder-guess-mailing-list-by-folder-name (folder)
+ "Return ML address guess by FOLDER name's last hierarchy.
+Use `wl-subscribed-mailing-list'."
+ (setq folder (car (elmo-folder-get-primitive-folder-list folder)))
+ (when (memq (elmo-folder-get-type folder)
+ '(localdir imap4 maildir))
+ (let (key mladdress)
+ (setq folder ; make folder name simple
+ (if (eq 'imap4 (elmo-folder-get-type folder))
+ (elmo-imap4-spec-mailbox (elmo-imap4-get-spec folder))
+ (substring folder 1)))
+ (when (string-match "[^\\./]+$" folder) ; last hierarchy
+ (setq key (regexp-quote
+ (concat (substring folder (match-beginning 0)) "@")))
+ (setq mladdress
+ (elmo-string-matched-member
+ key wl-subscribed-mailing-list 'case-ignore))
+ (if (stringp mladdress)
+ (list mladdress nil nil)
+ nil)))))
+
(defun wl-folder-update-diff-line (diffs)
(let ((inhibit-read-only t)
(buffer-read-only nil)
(save-excursion
(beginning-of-line)
(setq id (get-text-property (point) 'wl-folder-entity-id))
- (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)")
- ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
- (setq cur-new (string-to-int
+ (when (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*\\)/\\([0-9\\*-]*\\)/\\([0-9\\*]*\\)")
+ ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
+ (setq cur-new (string-to-int
(wl-match-buffer 2)))
- (setq cur-unread (string-to-int
+ (setq cur-unread (string-to-int
(wl-match-buffer 3)))
- (setq cur-all (string-to-int
+ (setq cur-all (string-to-int
(wl-match-buffer 4)))
(delete-region (match-beginning 2)
(match-end 4))
(goto-char (match-beginning 2))
- (insert (format "%s/%s/%s"
+ (insert (format "%s/%s/%s"
(setq new-new (+ cur-new (nth 0 diffs)))
(setq new-unread (+ cur-unread (nth 1 diffs)))
(setq new-all (+ cur-all (nth 2 diffs)))))
(put-text-property (match-beginning 2) (point)
'wl-folder-entity-id id)
- (if wl-use-highlight-mouse-line
+ (if wl-use-highlight-mouse-line
(put-text-property (match-beginning 2) (point)
'mouse-face 'highlight))
(wl-highlight-folder-group-line (list new-new new-unread new-all))
(save-excursion
(beginning-of-line)
(setq id (get-text-property (point) 'wl-folder-entity-id))
- (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
- ;;(looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
+ (if (looking-at "^[ ]*\\(.*\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
+;;; (looking-at "^[ ]*\\([^\\[].+\\):\\([0-9\\*-]*/[0-9\\*-]*/[0-9\\*]*\\)")
(progn
(delete-region (match-beginning 2)
(match-end 2))
(goto-char (match-beginning 2))
- (insert (format "%s/%s/%s"
+ (insert (format "%s/%s/%s"
(or (nth 0 nums) "*")
(or (and (nth 0 nums)(nth 1 nums)
(+ (nth 0 nums)(nth 1 nums)))
(defun wl-folder-goto-folder-subr (&optional folder sticky)
(beginning-of-line)
(let (summary-buf fld-name entity id error-selecting)
-;; (setq fld-name (wl-folder-get-entity-from-buffer))
-;; (if (or (null fld-name)
-;; (assoc fld-name wl-folder-group-alist))
+;;; (setq fld-name (wl-folder-get-entity-from-buffer))
+;;; (if (or (null fld-name)
+;;; (assoc fld-name wl-folder-group-alist))
(setq fld-name wl-default-folder)
(setq fld-name (or folder
(wl-summary-read-folder fld-name)))
(if (and summary-buf
(get-buffer-window summary-buf))
(delete-window)))
- (wl-summary-goto-folder-subr fld-name
+ (wl-summary-goto-folder-subr fld-name
(wl-summary-get-sync-range fld-name)
nil sticky t)))
(wl-folder-get-petname
(if (stringp (car path))
(car path)
- (wl-folder-get-folder-name-by-id
+ (wl-folder-get-folder-name-by-id
(car path))))))
(beginning-of-line)
(setq path (cdr path))
(if refresh
(let ((id (progn
(wl-folder-prev-entity-skip-invalid t)
- (wl-folder-get-entity-from-buffer t))))
- (mapcar '(lambda (x)
- (setcdr x t))
- wl-folder-group-alist)
+ (wl-folder-get-entity-from-buffer t)))
+ (alist wl-folder-group-alist))
+ (while alist
+ (setcdr (pop alist) t))
(erase-buffer)
(wl-folder-insert-entity " " wl-folder-entity)
(wl-folder-move-path id))
(point))
(save-excursion (end-of-line)
(+ 1 (point))))
- (setq i (1+ i))
- (and (zerop (% i 10))
- (elmo-display-progress
- 'wl-folder-open-all "Opening all folders..."
- (/ (* i 100) len))))))
- (elmo-display-progress
- 'wl-folder-open-all "Opening all folders..." 100)
+ (when (> len elmo-display-progress-threshold)
+ (setq i (1+ i))
+ (if (or (zerop (% i 5)) (= i len))
+ (elmo-display-progress
+ 'wl-folder-open-all "Opening all folders..."
+ (/ (* i 100) len)))))
+ (when (> len elmo-display-progress-threshold)
+ (elmo-display-progress
+ 'wl-folder-open-all "Opening all folders..." 100))))
+ (message "Opening all folders...done")
(set-buffer-modified-p nil)))
(defun wl-folder-close-all ()
(set-buffer-modified-p nil)))
(defun wl-folder-open-close ()
- "open or close parent entity."
+ "Open or close parent entity."
(interactive)
(save-excursion
(beginning-of-line)
(setq diff t)))
(t
(wl-append removes (list folder))))))
- (setq i (1+ i))
- (and (zerop (% i 10))
- (elmo-display-progress
- 'wl-folder-update-access-group "Updating access group..."
- (/ (* i 100) len)))
+ (when (> len elmo-display-progress-threshold)
+ (setq i (1+ i))
+ (if (or (zerop (% i 10)) (= i len))
+ (elmo-display-progress
+ 'wl-folder-update-access-group "Updating access group..."
+ (/ (* i 100) len))))
(setq flist (cdr flist)))
;; check unsubscribed groups
(while unsubscribes
(when (member (car unsubscribes) new-flist)
(setq new-flist (delete (car unsubscribes) new-flist))
(wl-append new-unsubscribes (list (car unsubscribes))))))
- (setq i (1+ i))
- (and (zerop (% i 10))
- (elmo-display-progress
- 'wl-folder-update-access-group "Updating access group..."
- (/ (* i 100) len)))
+ (when (> len elmo-display-progress-threshold)
+ (setq i (1+ i))
+ (if (or (zerop (% i 10)) (= i len))
+ (elmo-display-progress
+ 'wl-folder-update-access-group "Updating access group..."
+ (/ (* i 100) len))))
(setq unsubscribes (cdr unsubscribes)))
- (elmo-display-progress
- 'wl-folder-update-access-group "Updating access group..."
- 100)
;;
(if (or new-flist removes)
(setq diff t))
(list diff new-flist new-unsubscribes removes)))
(defun wl-folder-prefetch-entity (entity)
- "Prefetch all new messages in the ENTITY"
+ "Prefetch all new messages in the ENTITY."
(cond
((consp entity)
(let ((flist (nth 2 entity))
(sum-done 0)
- (sum-all 0)
+ (sum-all 0)
result)
(while flist
(setq result (wl-folder-prefetch-entity (car flist)))
(setq sum-done (+ sum-done (car result)))
(setq sum-all (+ sum-all (cdr result)))
(setq flist (cdr flist)))
- (message "Prefetched %d/%d message(s) in \"%s\"."
- sum-done sum-all
+ (message "Prefetched %d/%d message(s) in \"%s\"."
+ sum-done sum-all
(wl-folder-get-petname (car entity)))
(cons sum-done sum-all)))
((stringp entity)
entity))
wl-summary-highlight))
wl-summary-exit-next-move
- wl-auto-select-first ret-val
+ wl-auto-select-first ret-val
count)
(setq count (or (car nums) 0))
(setq count (+ count (wl-folder-count-incorporates entity)))
- (if (< 0 count)
- (save-window-excursion
- (save-excursion
- (wl-summary-goto-folder-subr entity
- (wl-summary-get-sync-range entity)
- nil)
- (setq ret-val (wl-summary-incorporate))
- (wl-summary-exit)
- ret-val))
+ (if (or (null (car nums)) ; unknown
+ (< 0 count))
+ (let ((wl-summary-buffer-name (concat
+ wl-summary-buffer-name
+ (symbol-name this-command)))
+ (wl-message-buf-name (concat wl-message-buf-name
+ (symbol-name this-command))))
+ (save-window-excursion
+ (save-excursion
+ (wl-summary-goto-folder-subr entity
+ (wl-summary-get-sync-range entity)
+ nil)
+ (setq ret-val (wl-summary-incorporate))
+ (wl-summary-exit)
+ ret-val)))
(cons 0 0))))))
(defun wl-folder-count-incorporates (folder)
- (let ((sum 0))
- (mapcar '(lambda (x)
- (if (member (cadr x)
- wl-summary-incorporate-marks)
- (incf sum)))
- (elmo-msgdb-mark-load (elmo-msgdb-expand-path folder)))
+ (let ((marks (elmo-msgdb-mark-load (elmo-msgdb-expand-path folder)))
+ (sum 0))
+ (while marks
+ (if (member (cadr (car marks))
+ wl-summary-incorporate-marks)
+ (incf sum))
+ (setq marks (cdr marks)))
sum))
(defun wl-folder-prefetch-current-entity (&optional no-check)
- "Prefetch all uncached messages in the folder at position.
+ "Prefetch all uncached messages in the folder at position.
If current line is group folder, all subfolders are prefetched."
(interactive "P")
(save-excursion
(wl-folder-prefetch-entity entity)))))
(defun wl-folder-drop-unsync-entity (entity)
- "Drop all unsync messages in the ENTITY"
+ "Drop all unsync messages in the ENTITY."
(cond
((consp entity)
(let ((flist (nth 2 entity)))
wl-summary-highlight wl-auto-select-first new)
(setq new (or (car nums) 0))
(if (< 0 new)
- (save-window-excursion
- (save-excursion
- (wl-summary-goto-folder-subr entity 'no-sync nil)
- (wl-summary-drop-unsync)
- (wl-summary-exit))))))))
+ (let ((wl-summary-buffer-name (concat
+ wl-summary-buffer-name
+ (symbol-name this-command)))
+ (wl-message-buf-name (concat wl-message-buf-name
+ (symbol-name this-command))))
+ (save-window-excursion
+ (save-excursion
+ (wl-summary-goto-folder-subr entity 'no-sync nil)
+ (wl-summary-drop-unsync)
+ (wl-summary-exit)))))))))
(defun wl-folder-drop-unsync-current-entity (&optional force-check)
- "Drop all unsync messages in the folder at position.
+ "Drop all unsync messages in the folder at position.
If current line is group folder, all subfolders are dropped.
If optional arg exists, don't check any folders."
(interactive "P")
wl-folder-check-entity-hook
summary-buf entity)
(when (and entity-name
- (y-or-n-p (format
+ (y-or-n-p (format
"Drop all unsync messages in %s?" entity-name)))
(setq entity
(if group
(wl-folder-drop-unsync-entity entity)
(message "All unsync messages in %s are dropped!" entity-name)))))
-(defun wl-folder-write-current-newsgroup ()
+(defun wl-folder-write-current-folder ()
+ "Write message to current folder's newsgroup or mailing-list.
+Call `wl-summary-write-current-folder' with current folder name."
(interactive)
- (wl-summary-write-current-newsgroup (wl-folder-entity-name)))
+ (unless (wl-folder-buffer-group-p)
+ (wl-summary-write-current-folder
+ (wl-folder-get-realname (wl-folder-entity-name)))))
(defun wl-folder-mimic-kill-buffer ()
"Kill the current (Folder) buffer with query."
(wl-exit)
(kill-buffer bufname))))
-(defun wl-folder-confirm-existence (fld &optional ignore-error)
- (if (or (wl-folder-entity-exists-p fld)
- (file-exists-p (elmo-msgdb-expand-path fld)))
- ()
- (if ignore-error
- (condition-case nil
- (if (elmo-folder-exists-p fld)
- ()
- (if (elmo-folder-creatable-p fld)
- (if (y-or-n-p
- (format "Folder %s does not exist, create it?" fld))
- (progn
- (setq wl-folder-entity-hashtb
- (wl-folder-create-entity-hashtb
- fld
- wl-folder-entity-hashtb))
- (elmo-create-folder fld)))))
- (error))
- (if (elmo-folder-exists-p fld)
- ()
- (if (not (elmo-folder-creatable-p fld))
- (error "Folder %s is not found" fld)
- (if (y-or-n-p
- (format "Folder %s does not exist, create it?" fld))
- (progn
- (setq wl-folder-entity-hashtb
- (wl-folder-create-entity-hashtb
- fld
- wl-folder-entity-hashtb))
- (unless (elmo-create-folder fld)
- (error "Create folder failed")))
- (error "Folder is not created")))))))
-
-(provide 'wl-folder)
+(defun wl-folder-create-subr (entity)
+ (if (not (elmo-folder-creatable-p entity))
+ (error "Folder %s is not found" entity)
+ (if (y-or-n-p
+ (format "Folder %s does not exist, create it?"
+ entity))
+ (progn
+ (setq wl-folder-entity-hashtb
+ (wl-folder-create-entity-hashtb
+ entity wl-folder-entity-hashtb))
+ (unless (elmo-create-folder entity)
+ (error "Create folder failed")))
+ (error "Folder %s is not created" entity))))
+
+(defun wl-folder-confirm-existence (folder &optional force)
+ (if force
+ (unless (elmo-folder-exists-p folder)
+ (wl-folder-create-subr folder))
+ (unless (or (wl-folder-entity-exists-p folder)
+ (file-exists-p (elmo-msgdb-expand-path folder))
+ (elmo-folder-exists-p folder))
+ (wl-folder-create-subr folder))))
+
+(require 'product)
+(product-provide (provide 'wl-folder) (require 'wl-version))
;;; wl-folder.el ends here
projects / elisp / wanderlust.git / blobdiff