Fix list-messages for new folder
[more-wl.git] / elmo / elmo-flag.el
blobb7e4e7163cb903913e3b50d093f2c39796171a16
1 ;;; elmo-flag.el --- global flag handling.
3 ;; Copyright (C) 2003 Yuuichi Teranishi <teranisi@gohome.org>
5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Keywords: mail, net news
8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
26 ;;; Commentary:
29 ;;; Code:
30 (require 'elmo-util)
31 (require 'elmo-localdir)
32 (eval-when-compile (require 'cl))
34 (defcustom elmo-global-flags '(important)
35 "A list of flag symbol which is managed globally by the flag folder."
36 :type '(repeat symbol)
37 :group 'elmo)
39 (defcustom elmo-local-flags '(unread any digest)
40 "A list of flag symbol which is not treated as global flag."
41 :type '(repeat symbol)
42 :group 'elmo)
44 (defvar elmo-global-flag-folder-alist nil
45 "Internal variable to hold global-flag-folder structures.")
47 (eval-and-compile
48 (defconst elmo-flag-char-regexp "]!#$&'+,./0-9:;<=>?@A-Z[^_`a-z|}~-"))
50 (defun elmo-flag-valid-p (flag)
51 (string-match (eval-when-compile
52 (concat "^[" elmo-flag-char-regexp "]+$"))
53 (if (stringp flag) flag (symbol-name flag))))
55 (eval-and-compile
56 (luna-define-class elmo-flag-folder (elmo-localdir-folder)
57 (flag minfo minfo-hash max-number))
58 (luna-define-internal-accessors 'elmo-flag-folder))
60 (luna-define-method elmo-folder-initialize ((folder
61 elmo-flag-folder)
62 name)
63 (unless (string-match (eval-when-compile
64 (concat "^flag\\(/\\(["
65 elmo-flag-char-regexp
66 "]+\\)\\)?$"))
67 name)
68 (error "Error in folder name `%s'" (elmo-folder-name-internal folder)))
69 (if (match-beginning 1)
70 (setq name (match-string 2 name))
71 (setq name (symbol-name (car elmo-global-flags)))
72 (elmo-folder-set-name-internal
73 folder
74 (concat (elmo-folder-name-internal folder) "/" name)))
75 (or (cdr (assq (intern name) elmo-global-flag-folder-alist))
76 (let ((flag (intern name))
77 msgdb-path)
78 (elmo-flag-folder-set-flag-internal folder flag)
79 (unless (elmo-global-flag-p flag)
80 (setq elmo-global-flags
81 (nconc elmo-global-flags (list flag))))
82 ;; must be AFTER set flag slot.
83 (setq msgdb-path (elmo-folder-msgdb-path folder))
84 (unless (file-directory-p msgdb-path)
85 (elmo-make-directory msgdb-path))
86 (elmo-localdir-folder-set-dir-name-internal
87 folder
88 msgdb-path)
89 (elmo-localdir-folder-set-directory-internal
90 folder
91 msgdb-path)
92 (if (file-exists-p (expand-file-name "max" msgdb-path))
93 (elmo-flag-folder-set-max-number-internal
94 folder
95 (elmo-object-load (expand-file-name "max" msgdb-path))))
96 (elmo-flag-folder-set-minfo
97 folder
98 (and (file-exists-p (expand-file-name ".minfo" msgdb-path))
99 (elmo-object-load (expand-file-name ".minfo" msgdb-path))))
100 (setq elmo-global-flag-folder-alist
101 (cons (cons flag folder) elmo-global-flag-folder-alist))
102 folder)))
104 (defun elmo-flag-folder-set-minfo (folder minfo)
105 (let ((hash (elmo-make-hash (length minfo))))
106 (dolist (elem minfo)
107 (elmo-set-hash-val (nth 1 elem) elem hash)
108 (elmo-set-hash-val (concat "#" (number-to-string (nth 2 elem)))
109 elem hash)
110 (dolist (pair (car elem))
111 (elmo-set-hash-val (concat (number-to-string (cdr pair))
112 ":" (car pair))
113 elem hash)))
114 (elmo-flag-folder-set-minfo-internal folder minfo)
115 (elmo-flag-folder-set-minfo-hash-internal folder hash)))
117 (luna-define-method elmo-folder-expand-msgdb-path ((folder elmo-flag-folder))
118 (expand-file-name (concat "flag/"
119 (elmo-replace-string-as-filename
120 (symbol-name
121 (elmo-flag-folder-flag-internal folder))))
122 elmo-msgdb-directory))
124 (luna-define-method elmo-folder-commit :after ((folder
125 elmo-flag-folder))
126 (elmo-object-save
127 (expand-file-name ".minfo" (elmo-folder-msgdb-path folder))
128 (elmo-flag-folder-minfo-internal folder)
129 elmo-mime-charset)
130 (if (elmo-flag-folder-max-number-internal folder)
131 (elmo-object-save
132 (expand-file-name "max" (elmo-folder-msgdb-path folder))
133 (elmo-flag-folder-max-number-internal folder))))
135 (luna-define-method elmo-folder-list-subfolders ((folder elmo-flag-folder)
136 &optional one-level)
137 (mapcar (lambda (flag)
138 (concat
139 (elmo-folder-prefix-internal folder)
140 (symbol-name (elmo-folder-type-internal folder))
142 (symbol-name flag)))
143 elmo-global-flags))
145 (defun elmo-flag-folder-delete-message (folder number
146 &optional keep-referrer)
147 (let* ((elem (elmo-get-hash-val (concat "#" (number-to-string number))
148 (elmo-flag-folder-minfo-hash-internal
149 folder)))
150 target-folder key)
151 (dolist (pair (car elem))
152 (when (and (car pair) (cdr pair))
153 (elmo-clear-hash-val (concat (number-to-string (cdr pair)) ":"
154 (car pair))
155 (elmo-flag-folder-minfo-hash-internal
156 folder))
157 (unless keep-referrer
158 (setq target-folder (elmo-get-folder (car pair)))
159 (elmo-folder-open target-folder 'load-msgdb)
160 ;; Unset the flag of the original folder.
161 ;; (XXX Should the message-id checked?)
162 (elmo-message-unset-flag target-folder (cdr pair)
163 (elmo-flag-folder-flag-internal folder))
164 (elmo-folder-close target-folder))))
165 (elmo-clear-hash-val (concat "#" (number-to-string number))
166 (elmo-flag-folder-minfo-hash-internal
167 folder))
168 (elmo-clear-hash-val (nth 1 elem) (elmo-flag-folder-minfo-hash-internal
169 folder))
170 (elmo-flag-folder-set-minfo-internal
171 folder
172 (delq elem (elmo-flag-folder-minfo-internal folder))))
175 (luna-define-method elmo-folder-delete-messages-internal ((folder
176 elmo-flag-folder)
177 numbers)
178 (dolist (number numbers)
179 (elmo-flag-folder-delete-message folder number)
180 (elmo-localdir-delete-message folder number))
181 (elmo-folder-commit folder)
184 ;; Same as localdir except that the flag is always the flag.
185 (luna-define-method elmo-folder-msgdb-create ((folder elmo-flag-folder)
186 numbers
187 flag-table)
188 (when numbers
189 (let ((dir (elmo-localdir-folder-directory-internal folder))
190 (new-msgdb (elmo-make-msgdb))
191 (flags (list (elmo-flag-folder-flag-internal folder)))
192 entity)
193 (elmo-with-progress-display (elmo-folder-msgdb-create (length numbers))
194 "Creating msgdb"
195 (dolist (number numbers)
196 (when (setq entity (elmo-localdir-msgdb-create-entity
197 new-msgdb dir number))
198 (elmo-msgdb-append-entity new-msgdb entity flags))
199 (elmo-progress-notify 'elmo-folder-msgdb-create)))
200 new-msgdb)))
202 (defun elmo-folder-append-messages-*-flag (dst-folder
203 src-folder
204 numbers
205 same-number)
206 (let ((flag (elmo-flag-folder-flag-internal dst-folder)))
207 (dolist (number numbers)
208 (elmo-global-flag-set flag src-folder number
209 (elmo-message-field
210 src-folder number 'message-id)))
211 (elmo-folder-set-flag src-folder numbers flag))
212 numbers)
214 (luna-define-method elmo-folder-append-buffer ((folder elmo-flag-folder)
215 &optional flag number)
216 (error "Cannot append to the flag folder"))
218 (luna-define-method elmo-folder-unset-flag :before ((folder elmo-flag-folder)
219 numbers
220 flag
221 &optional is-local)
222 (when (eq flag (elmo-flag-folder-flag-internal folder))
223 (error "Cannot unset flag `%s' in this folder" flag)))
225 ;;; Utilities
227 (defmacro elmo-flag-get-folder (flag)
228 "Get the flag folder structure for FLAG."
229 `(when (memq ,flag elmo-global-flags)
230 (elmo-get-folder (concat "'flag/" (symbol-name ,flag)))))
232 (defun elmo-flag-folder-referrer (folder number)
233 "Return a list of referrer message information.
234 Each element is a cons cell like following:
235 \(FNAME . NUMBER\)
236 FNAME is the name of the folder which the message is contained.
237 NUMBER is the number of the message."
238 (when (eq (elmo-folder-type-internal folder) 'flag)
239 (car (elmo-get-hash-val (concat "#" (number-to-string number))
240 (elmo-flag-folder-minfo-hash-internal
241 folder)))))
243 ;;; Global-Flag API
244 (defun elmo-global-flag-p (flag)
245 "Return non-nil when FLAG is global."
246 (memq flag elmo-global-flags))
248 (defun elmo-global-flags (fname number)
249 "Return a list of global flags for the message.
250 FNAME is the name string of the folder.
251 NUMBER is the number of the message."
252 (let ((flag-list elmo-global-flags)
253 folder matches)
254 (while flag-list
255 (setq folder (elmo-flag-get-folder (car flag-list)))
256 (when (elmo-get-hash-val
257 (concat (number-to-string number) ":" fname)
258 (elmo-flag-folder-minfo-hash-internal folder))
259 (setq matches (cons (elmo-flag-folder-flag-internal folder)
260 matches)))
261 (setq flag-list (cdr flag-list)))
262 matches))
264 (defun elmo-folder-list-global-flag-messages (folder flag)
265 "List messages which have global flag.
266 FOLDER is the elmo folder structure.
267 FLAG is the symbol of the flag."
268 (when (elmo-global-flag-p flag)
269 (let ((flag-folder (elmo-flag-get-folder flag))
270 result number)
271 (dolist (elem (elmo-flag-folder-minfo-internal flag-folder))
272 (if (setq number (elmo-message-number folder (nth 1 elem)))
273 (setq result (cons number result))))
274 result)))
277 ;; minfo is a list of following cell.
278 ;; ((((FNAME . NUMBER)...(FNAME . NUMBER)) MESSAGE-ID NUMBER-IN-FLAG-FOLDER)
279 ;; minfo-index is the hash table of above with following indice;
280 (defun elmo-global-flags-set (flags folder number message-id)
281 "Set global flags to the message.
282 FLAGS is a list of symbol of the flag.
283 FOLDER is the elmo folder structure.
284 NUMBER is the message number."
285 (dolist (flag flags)
286 (elmo-global-flag-set flag folder number message-id)))
288 (defun elmo-local-flag-p (flag)
289 "Return non-nil when flag is not appropriate for global flag."
290 (memq flag elmo-local-flags))
292 (defsubst elmo-global-flag-set-internal (flag folder number message-id)
293 (when (elmo-local-flag-p flag)
294 (error "Cannot treat `%s' as global flag" flag))
295 (when message-id
296 (let ((flag-folder (elmo-flag-get-folder flag))
297 filename cache new-file new-number elem)
298 (if (setq elem (elmo-get-hash-val
299 message-id
300 (elmo-flag-folder-minfo-hash-internal
301 flag-folder)))
302 ;; Same ID already exists.
303 (when (and folder number
304 (not (member (cons (elmo-folder-name-internal folder)
305 number) (car elem))))
306 (setcar elem
307 (cons (cons (elmo-folder-name-internal folder)
308 number) (car elem)))
309 (setq new-number (nth 2 elem))
310 (elmo-set-hash-val (concat (number-to-string number)
311 ":" (elmo-folder-name-internal
312 folder))
313 elem
314 (elmo-flag-folder-minfo-hash-internal
315 flag-folder)))
316 ;; Append new element.
317 (elmo-flag-folder-set-max-number-internal
318 flag-folder
319 (+ (or (elmo-flag-folder-max-number-internal flag-folder)
320 ;; This is the first time.
321 (car (elmo-folder-status flag-folder)))
323 (setq new-file
324 (expand-file-name
325 (int-to-string
326 (setq new-number
327 (elmo-flag-folder-max-number-internal flag-folder)))
328 (elmo-localdir-folder-directory-internal flag-folder)))
329 (cond
330 ((setq filename (elmo-message-file-name folder number))
331 (elmo-copy-file filename new-file))
332 ((and (setq cache (elmo-file-cache-get message-id))
333 (eq (elmo-file-cache-status cache) 'entire))
334 (elmo-copy-file (elmo-file-cache-path cache) new-file))
336 (with-temp-buffer
337 (elmo-message-fetch folder number
338 (elmo-make-fetch-strategy 'entire))
339 (write-region-as-binary (point-min) (point-max) new-file nil
340 'no-msg))))
341 (elmo-flag-folder-set-minfo-internal
342 flag-folder
343 (cons
344 (setq elem (list
345 (when (and folder number)
346 (list (cons (elmo-folder-name-internal folder)
347 number)))
348 message-id
349 new-number))
350 (elmo-flag-folder-minfo-internal flag-folder)))
351 (when (and folder number)
352 (elmo-set-hash-val (concat (number-to-string number)
353 ":" (elmo-folder-name-internal
354 folder))
355 elem
356 (elmo-flag-folder-minfo-hash-internal
357 flag-folder)))
358 (elmo-set-hash-val message-id elem
359 (elmo-flag-folder-minfo-hash-internal
360 flag-folder))
361 (elmo-set-hash-val (concat "#" (number-to-string new-number)) elem
362 (elmo-flag-folder-minfo-hash-internal
363 flag-folder)))
364 (elmo-folder-commit flag-folder)
365 new-number)))
367 (defun elmo-global-flag-set (flag folder number message-id)
368 "Set global flag to the message.
369 FLAG is a symbol of the flag.
370 FOLDER is the elmo folder structure.
371 NUMBER is the message number.
372 MESSAGE-ID is the message-id of the message."
373 (when (elmo-global-flag-p flag)
374 (elmo-global-flag-set-internal flag folder number message-id)))
376 (defun elmo-global-flag-detach (flag folder number &optional delete-if-none)
377 "Detach the message from the global flag.
378 FOLDER is the folder structure.
379 NUMBERS is the message number.
380 If optional DELETE-IF-NONE is non-nil, delete message from flag folder when
381 the message is not flagged in any folder.
382 If DELETE-IF-NONE is a symbol `always',
383 delete message without flagged in other folder."
384 (unless (and (eq (elmo-folder-type-internal folder) 'flag)
385 (eq (elmo-flag-folder-flag-internal folder) flag))
386 (let ((flag-folder (elmo-flag-get-folder flag))
387 elem key)
388 (when flag-folder
389 (setq key (concat (number-to-string number) ":"
390 (elmo-folder-name-internal folder))
391 elem (elmo-get-hash-val
393 (elmo-flag-folder-minfo-hash-internal flag-folder)))
394 (when elem
395 (setcar elem (delete (cons (elmo-folder-name-internal folder)
396 number) (car elem)))
397 (elmo-clear-hash-val key (elmo-flag-folder-minfo-hash-internal
398 flag-folder))
399 ;; Does not have any referrer, remove.
400 (when (and delete-if-none
401 (or (eq delete-if-none 'always)
402 (null (car elem))))
403 (elmo-flag-folder-delete-message flag-folder (nth 2 elem)
404 (null (car elem)))
405 (elmo-localdir-delete-message flag-folder (nth 2 elem))
406 (elmo-folder-commit flag-folder)))))))
408 (defun elmo-global-flag-detach-messages (folder numbers &optional
409 delete-if-none)
410 "Detach all messages specified from all global flags.
411 FOLDER is the folder structure.
412 NUMBERS is the message number list.
413 If optional DELETE-IF-NONE is non-nil, delete message from flag folder when
414 the message is not flagged in any folder."
415 (unless (eq (elmo-folder-type-internal folder) 'flag)
416 (dolist (flag elmo-global-flags)
417 (dolist (number numbers)
418 (elmo-global-flag-detach flag folder number delete-if-none)))))
420 (defun elmo-global-flag-replace-referrer (old-folder new-folder)
421 (dolist (flag elmo-global-flags)
422 (let* ((folder (elmo-flag-get-folder flag))
423 (minfo (elmo-flag-folder-minfo-internal folder))
424 modified)
425 (dolist (entry minfo)
426 (let ((pair (assoc old-folder (nth 0 entry))))
427 (when pair
428 (setcar pair new-folder)
429 (setq modified t))))
430 (when modified
431 (elmo-flag-folder-set-minfo folder minfo)
432 (elmo-folder-commit folder)))))
434 (defun elmo-get-global-flags (&optional flags ignore-preserved)
435 "Get global flags.
436 Return value is a subset of optional argument FLAGS.
437 If FLAGS is `t', all global flags becomes candidates.
438 If optional IGNORE-PRESERVED is non-nil, preserved flags
439 \(answered, cached, new, unread\) are not included."
440 (let ((result (copy-sequence (if (eq flags t)
441 (setq flags elmo-global-flags)
442 flags))))
443 (while flags
444 (unless (elmo-global-flag-p (car flags))
445 (setq result (delq (car flags) result)))
446 (setq flags (cdr flags)))
447 (when ignore-preserved
448 (dolist (flag elmo-preserved-flags)
449 (setq result (delq flag result))))
450 result))
452 (defun elmo-global-flags-initialize (&optional additional-flags)
453 (let ((dir (expand-file-name "flag" elmo-msgdb-directory)))
454 (setq elmo-global-flags
455 (elmo-list-delete
456 elmo-local-flags
457 (elmo-uniq-list
458 (append
459 elmo-global-flags
460 additional-flags
461 (and (file-directory-p dir)
462 (mapcar (lambda (x)
463 (intern (elmo-recover-string-from-filename x)))
464 (elmo-list-delete
465 '(".." ".")
466 (directory-files dir))))))
467 #'delq))))
469 ;;; To migrate from global mark folder
470 (defvar elmo-global-mark-filename "global-mark"
471 "Obsolete variable. (Just for migration)")
473 (defun elmo-global-mark-migrate ()
474 "Migrate from 'mark to 'flag. For automatic migration."
475 (when (and (file-exists-p (expand-file-name elmo-global-mark-filename
476 elmo-msgdb-directory))
477 (elmo-global-flag-p 'important)
478 (not (file-exists-p (elmo-folder-msgdb-path
479 (elmo-flag-get-folder 'important)))))
480 (elmo-global-mark-upgrade)))
482 (defun elmo-global-mark-upgrade ()
483 "Upgrade old `global-mark' structure."
484 (interactive)
485 (when (file-exists-p (expand-file-name
486 elmo-global-mark-filename elmo-msgdb-directory))
487 (message "Upgrading flag structure...")
488 (when (elmo-global-flag-p 'important)
489 (let ((global-marks
490 (elmo-object-load
491 (expand-file-name
492 elmo-global-mark-filename elmo-msgdb-directory)))
493 (folder (elmo-flag-get-folder 'important))
494 file-cache)
495 (dolist (elem global-marks)
496 (setq file-cache (elmo-file-cache-get (car elem)))
497 (when (eq (elmo-file-cache-status file-cache) 'entire)
498 (elmo-global-flag-set 'important nil nil (car elem))))))
499 (message "Upgrading flag structure...done")))
501 (luna-define-method elmo-folder-delete :around ((folder elmo-flag-folder))
502 (let ((flag (elmo-flag-folder-flag-internal folder)))
503 (when (luna-call-next-method)
504 (setq elmo-global-flags (delq flag elmo-global-flags))
505 (setq elmo-global-flag-folder-alist
506 (delq (assq flag elmo-global-flag-folder-alist)
507 elmo-global-flag-folder-alist))
508 t)))
510 (require 'product)
511 (product-provide (provide 'elmo-flag) (require 'elmo-version))
513 ;;; elmo-flag.el ends here