elmo/elmo-flag.el

   1 ;;; elmo-flag.el --- global flag handling.
   2
   3 ;; Copyright (C) 2003 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
   9
  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.
  14 ;;
  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.
  19 ;;
  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.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28 (require 'elmo-util)
  29 (require 'elmo-localdir)
  30 (eval-when-compile (require 'cl))
  31
  32 ;;; Code:
  33 (defcustom elmo-global-flags '(important)
  34   "A list of flag symbol which is managed globally by the flag folder."
  35   :type '(repeat symbol)
  36   :group 'elmo)
  37
  38 (defcustom elmo-local-flags '(unread any digest)
  39   "A list of flag symbol which is not treated as global flag."
  40   :type '(repeat symbol)
  41   :group 'elmo)
  42
  43 (defvar elmo-global-flag-folder-alist nil
  44   "Internal variable to hold global-flag-folder structures.")
  45
  46 (eval-and-compile
  47   (luna-define-class elmo-flag-folder (elmo-localdir-folder)
  48                      (flag minfo minfo-hash max-number))
  49   (luna-define-internal-accessors 'elmo-flag-folder))
  50
  51 (luna-define-method elmo-folder-initialize ((folder
  52                                              elmo-flag-folder)
  53                                             name)
  54   (if (string-match "flag/\\([a-z]+\\)" name)
  55       (setq name (match-string 1 name))
  56     (setq name (symbol-name (car elmo-global-flags)))
  57     (elmo-folder-set-name-internal
  58      folder
  59      (concat (elmo-folder-name-internal folder) "/" name)))
  60   (or (cdr (assq (intern name) elmo-global-flag-folder-alist))
  61       (let ((flag (intern name))
  62             msgdb-path)
  63         (elmo-flag-folder-set-flag-internal folder flag)
  64         (unless (elmo-global-flag-p flag)
  65           (setq elmo-global-flags
  66                 (nconc elmo-global-flags (list flag))))
  67         ;; must be AFTER set flag slot.
  68         (setq msgdb-path (elmo-folder-msgdb-path folder))
  69         (unless (file-directory-p msgdb-path)
  70           (elmo-make-directory msgdb-path))
  71         (elmo-localdir-folder-set-dir-name-internal
  72          folder
  73          msgdb-path)
  74         (elmo-localdir-folder-set-directory-internal
  75          folder
  76          msgdb-path)
  77         (if (file-exists-p (expand-file-name "max" msgdb-path))
  78             (elmo-flag-folder-set-max-number-internal
  79              folder
  80              (elmo-object-load (expand-file-name "max" msgdb-path))))
  81         (if (file-exists-p (expand-file-name ".minfo" msgdb-path))
  82             (elmo-flag-folder-set-minfo-internal
  83              folder
  84              (elmo-object-load (expand-file-name ".minfo" msgdb-path))))
  85         (elmo-flag-folder-set-minfo-hash-internal
  86          folder
  87          (elmo-make-hash (length (elmo-flag-folder-minfo-internal folder))))
  88         (dolist (elem (elmo-flag-folder-minfo-internal folder))
  89           (elmo-set-hash-val (nth 1 elem) elem
  90                              (elmo-flag-folder-minfo-hash-internal folder))
  91           (elmo-set-hash-val (concat "#" (number-to-string (nth 2 elem)))
  92                              elem
  93                              (elmo-flag-folder-minfo-hash-internal folder))
  94           (dolist (pair (car elem))
  95             (elmo-set-hash-val (concat (number-to-string (cdr pair))
  96                                        ":" (car pair))
  97                                elem
  98                                (elmo-flag-folder-minfo-hash-internal folder))))
  99         (setq elmo-global-flag-folder-alist
 100               (cons (cons flag folder) elmo-global-flag-folder-alist))
 101         folder)))
 102
 103 (luna-define-method elmo-folder-expand-msgdb-path ((folder elmo-flag-folder))
 104   (expand-file-name (concat "flag/"
 105                             (symbol-name
 106                              (elmo-flag-folder-flag-internal folder)))
 107                     elmo-msgdb-directory))
 108
 109 (luna-define-method elmo-folder-commit :after ((folder
 110                                                 elmo-flag-folder))
 111   (elmo-object-save
 112    (expand-file-name ".minfo" (elmo-folder-msgdb-path folder))
 113    (elmo-flag-folder-minfo-internal folder))
 114   (if (elmo-flag-folder-max-number-internal folder)
 115       (elmo-object-save
 116        (expand-file-name "max" (elmo-folder-msgdb-path folder))
 117        (elmo-flag-folder-max-number-internal folder))))
 118
 119 (luna-define-method elmo-folder-list-subfolders ((folder elmo-flag-folder)
 120                                                  &optional one-level)
 121   (let ((dir (expand-file-name "flag" elmo-msgdb-directory)))
 122     (mapcar (lambda (flag)
 123               (concat
 124                (elmo-folder-prefix-internal folder)
 125                (symbol-name (elmo-folder-type-internal folder))
 126                "/"
 127                (symbol-name flag)))
 128             (elmo-uniq-list
 129              (append
 130               (mapcar 'intern (delete ".." (delete "." (directory-files dir))))
 131               elmo-global-flags)))))
 132
 133 (defun elmo-flag-folder-delete-message (folder number
 134                                                &optional keep-referrer)
 135   (let* ((elem (elmo-get-hash-val (concat "#" (number-to-string number))
 136                                   (elmo-flag-folder-minfo-hash-internal
 137                                    folder)))
 138          target-folder key)
 139     (dolist (pair (car elem))
 140       (when (and (car pair) (cdr pair))
 141         (elmo-clear-hash-val (concat (number-to-string (cdr pair)) ":"
 142                                      (car pair))
 143                              (elmo-flag-folder-minfo-hash-internal
 144                               folder))
 145         (unless keep-referrer
 146           (setq target-folder (elmo-make-folder (car pair)))
 147           (elmo-folder-open target-folder 'load-msgdb)
 148           ;; Unset the flag of the original folder.
 149           ;; (XXX Should the message-id checked?)
 150           (elmo-message-unset-flag target-folder (cdr pair)
 151                                    (elmo-flag-folder-flag-internal folder))
 152           (elmo-folder-close target-folder))))
 153     (elmo-clear-hash-val (concat "#" (number-to-string number))
 154                          (elmo-flag-folder-minfo-hash-internal
 155                           folder))
 156     (elmo-clear-hash-val (nth 1 elem) (elmo-flag-folder-minfo-hash-internal
 157                                        folder))
 158     (elmo-flag-folder-set-minfo-internal
 159      folder
 160      (delq elem (elmo-flag-folder-minfo-internal folder))))
 161   t)
 162
 163 (luna-define-method elmo-folder-delete-messages ((folder
 164                                                   elmo-flag-folder)
 165                                                  numbers)
 166   (dolist (number numbers)
 167     (elmo-flag-folder-delete-message folder number)
 168     (elmo-localdir-delete-message folder number))
 169   (elmo-folder-commit folder)
 170   t)
 171
 172 ;; Same as localdir except that the flag is always the flag.
 173 (luna-define-method elmo-folder-msgdb-create ((folder elmo-flag-folder)
 174                                               numbers
 175                                               flag-table)
 176   (when numbers
 177     (let ((dir (elmo-localdir-folder-directory-internal folder))
 178           (new-msgdb (elmo-make-msgdb))
 179           entity (i 0)
 180           (len (length numbers)))
 181       (message "Creating msgdb...")
 182       (while numbers
 183         (when (setq entity (elmo-localdir-msgdb-create-entity
 184                             new-msgdb dir (car numbers)))
 185           (elmo-msgdb-append-entity new-msgdb entity
 186                                     (list (elmo-flag-folder-flag-internal
 187                                            folder))))
 188         (when (> len elmo-display-progress-threshold)
 189           (setq i (1+ i))
 190           (elmo-display-progress
 191            'elmo-flag-folder-msgdb-create "Creating msgdb..."
 192            (/ (* i 100) len)))
 193         (setq numbers (cdr numbers)))
 194       (message "Creating msgdb...done")
 195       new-msgdb)))
 196
 197 (luna-define-method elmo-folder-append-messages ((folder elmo-flag-folder)
 198                                                  src-folder
 199                                                  numbers
 200                                                  &optional same-number)
 201   (dolist (number numbers)
 202     (elmo-global-flag-set (elmo-flag-folder-flag-internal folder)
 203                           src-folder number (elmo-message-field
 204                                              src-folder
 205                                              number
 206                                              'message-id)))
 207   (elmo-folder-set-flag src-folder
 208                         numbers
 209                         (elmo-flag-folder-flag-internal folder))
 210   numbers)
 211
 212 (luna-define-method elmo-folder-append-buffer ((folder elmo-flag-folder)
 213                                                &optional flag number)
 214   (error "Cannot append to the flag folder"))
 215
 216 ;;; Utilities
 217
 218 (defmacro elmo-flag-get-folder (flag)
 219   "Get the flag folder structure for FLAG."
 220   `(when (memq ,flag elmo-global-flags)
 221      (elmo-make-folder (concat  "'flag/" (symbol-name ,flag)))))
 222
 223 (defun elmo-flag-folder-referrer (folder number)
 224   "Return a list of referrer message information.
 225 Each element is a cons cell like following:
 226 \(FNAME . NUMBER\)
 227 FNAME is the name of the folder which the message is contained.
 228 NUMBER is the number of the message."
 229   (when (eq (elmo-folder-type-internal folder) 'flag)
 230     (car (elmo-get-hash-val (concat "#" (number-to-string number))
 231                             (elmo-flag-folder-minfo-hash-internal
 232                              folder)))))
 233
 234 ;;; Global-Flag API
 235 (defun elmo-global-flag-p (flag)
 236   "Return non-nil when FLAG is global."
 237   (memq flag elmo-global-flags))
 238
 239 (defun elmo-global-flags (fname number)
 240   "Return a list of global flags for the message.
 241 FNAME is the name string of the folder.
 242 NUMBER is the number of the message."
 243   (let ((flag-list elmo-global-flags)
 244         folder matches)
 245     (while flag-list
 246       (setq folder (elmo-flag-get-folder (car flag-list)))
 247       (when (elmo-get-hash-val
 248              (concat (number-to-string number) ":" fname)
 249              (elmo-flag-folder-minfo-hash-internal folder))
 250         (setq matches (cons (elmo-flag-folder-flag-internal folder)
 251                             matches)))
 252       (setq flag-list (cdr flag-list)))
 253     matches))
 254
 255 (defun elmo-folder-list-global-flag-messages (folder flag)
 256   "List messages which have global flag.
 257 FOLDER is the elmo folder structure.
 258 FLAG is the symbol of the flag."
 259   (when (elmo-global-flag-p flag)
 260     (let ((flag-folder (elmo-flag-get-folder flag))
 261           result number)
 262       (dolist (elem (elmo-flag-folder-minfo-internal flag-folder))
 263         (if (setq number (elmo-message-number folder (nth 1 elem)))
 264             (setq result (cons number result))))
 265       result)))
 266
 267 ;;;
 268 ;; minfo is a list of following cell.
 269 ;; ((((FNAME . NUMBER)...(FNAME . NUMBER)) MESSAGE-ID NUMBER-IN-FLAG-FOLDER)
 270 ;; minfo-index is the hash table of above with following indice;
 271 (defun elmo-global-flags-set (flags folder number message-id)
 272   "Set global flags to the message.
 273 FLAGS is a list of symbol of the flag.
 274 FOLDER is the elmo folder structure.
 275 NUMBER is the message number."
 276   (dolist (flag flags)
 277     (elmo-global-flag-set flag folder number message-id)))
 278
 279 (defun elmo-local-flag-p (flag)
 280   "Return non-nil when flag is not appropriate for global flag."
 281   (memq flag elmo-local-flags))
 282
 283 (defsubst elmo-global-flag-set-internal (flag folder number message-id)
 284   (when (elmo-local-flag-p flag)
 285     (error "Cannot treat `%s' as global flag." flag))
 286   (when message-id
 287     (let ((flag-folder (elmo-flag-get-folder flag))
 288           cache new-file new-number elem)
 289       (if (setq elem (elmo-get-hash-val
 290                       message-id
 291                       (elmo-flag-folder-minfo-hash-internal
 292                        flag-folder)))
 293           ;; Same ID already exists.
 294           (when (and folder number
 295                      (not (member (cons (elmo-folder-name-internal folder)
 296                                         number) (car elem))))
 297             (setcar elem
 298                     (cons (cons (elmo-folder-name-internal folder)
 299                                 number) (car elem)))
 300             (setq new-number (nth 2 elem))
 301             (elmo-set-hash-val (concat (number-to-string number)
 302                                        ":" (elmo-folder-name-internal
 303                                             folder))
 304                                elem
 305                                (elmo-flag-folder-minfo-hash-internal
 306                                 flag-folder)))
 307         ;; Append new element.
 308         (elmo-flag-folder-set-max-number-internal
 309          flag-folder
 310          (+ (or (elmo-flag-folder-max-number-internal flag-folder)
 311                 ;; This is the first time.
 312                 (car (elmo-folder-status flag-folder)))
 313             1))
 314         (setq new-file
 315               (expand-file-name
 316                (int-to-string
 317                 (setq new-number
 318                       (elmo-flag-folder-max-number-internal flag-folder)))
 319                (elmo-localdir-folder-directory-internal flag-folder)))
 320         (with-temp-buffer
 321           (setq cache (and message-id (elmo-file-cache-get message-id)))
 322           (if (and cache (eq (elmo-file-cache-status cache) 'entire))
 323               (elmo-copy-file (elmo-file-cache-path cache)
 324                               new-file)
 325             (when (and folder number)
 326               (elmo-message-fetch folder number (elmo-make-fetch-strategy
 327                                                  'entire)
 328                                   nil (current-buffer))
 329               (write-region-as-binary (point-min) (point-max) new-file nil
 330                                       'no-msg))))
 331         (elmo-flag-folder-set-minfo-internal
 332          flag-folder
 333          (cons
 334           (setq elem (list
 335                       (when (and folder number)
 336                         (list (cons (elmo-folder-name-internal folder)
 337                                     number)))
 338                       message-id
 339                       new-number))
 340           (elmo-flag-folder-minfo-internal flag-folder)))
 341         (when (and folder number)
 342           (elmo-set-hash-val (concat (number-to-string number)
 343                                      ":" (elmo-folder-name-internal
 344                                           folder))
 345                              elem
 346                              (elmo-flag-folder-minfo-hash-internal
 347                               flag-folder)))
 348         (elmo-set-hash-val message-id elem
 349                            (elmo-flag-folder-minfo-hash-internal
 350                             flag-folder))
 351         (elmo-set-hash-val (concat "#" (number-to-string new-number)) elem
 352                            (elmo-flag-folder-minfo-hash-internal
 353                             flag-folder)))
 354       (elmo-folder-commit flag-folder)
 355       new-number)))
 356
 357 (defun elmo-global-flag-set (flag folder number message-id)
 358   "Set global flag to the message.
 359 FLAG is a symbol of the flag.
 360 FOLDER is the elmo folder structure.
 361 NUMBER is the message number.
 362 MESSAGE-ID is the message-id of the message."
 363   (when (elmo-global-flag-p flag)
 364     (elmo-global-flag-set-internal flag folder number message-id)))
 365
 366 (defun elmo-global-flag-detach (flag folder number &optional delete-if-none)
 367   "Detach the message from the global flag.
 368 FOLDER is the folder structure.
 369 NUMBERS is the message number.
 370 If optional DELETE-IF-NONE is non-nil, delete message from flag folder when
 371 the message is not flagged in any folder.
 372 If DELETE-IF-NONE is a symbol `always',
 373 delete message without flagged in other folder."
 374   (unless (eq (elmo-folder-type-internal folder) 'flag)
 375     (let ((flag-folder (elmo-flag-get-folder flag))
 376           elem key)
 377       (when flag-folder
 378         (setq key (concat (number-to-string number) ":"
 379                           (elmo-folder-name-internal folder))
 380               elem (elmo-get-hash-val
 381                     key
 382                     (elmo-flag-folder-minfo-hash-internal flag-folder)))
 383         (when elem
 384           (setcar elem (delete (cons (elmo-folder-name-internal folder)
 385                                      number) (car elem)))
 386           (elmo-clear-hash-val key (elmo-flag-folder-minfo-hash-internal
 387                                     flag-folder))
 388           ;; Does not have any referrer, remove.
 389           (when (and delete-if-none
 390                      (or (eq delete-if-none 'always)
 391                          (null (car elem))))
 392             (elmo-flag-folder-delete-message flag-folder (nth 2 elem)
 393                                              (null (car elem)))
 394             (elmo-localdir-delete-message flag-folder (nth 2 elem))
 395             (elmo-folder-commit flag-folder)))))))
 396
 397 (defun elmo-global-flag-detach-messages (folder numbers &optional
 398                                                 delete-if-none)
 399   "Detach all messages specified from all global flags.
 400 FOLDER is the folder structure.
 401 NUMBERS is the message number list.
 402 If optional DELETE-IF-NONE is non-nil, delete message from flag folder when
 403 the message is not flagged in any folder."
 404   (unless (eq (elmo-folder-type-internal folder) 'flag)
 405     (dolist (flag elmo-global-flags)
 406       (dolist (number numbers)
 407         (elmo-global-flag-detach flag folder number delete-if-none)))))
 408
 409 (defun elmo-get-global-flags (&optional flags ignore-preserved)
 410   "Get global flags.
 411 Return value is a subset of optional argument FLAGS.
 412 If FLAGS is `t', all global flags becomes candidates.
 413 If optional IGNORE-PRESERVED is non-nil, preserved flags
 414 \(answered, cached, new, unread\) are not included."
 415   (let ((result (copy-sequence (if (eq flags t)
 416                                    (setq flags elmo-global-flags)
 417                                  flags))))
 418     (while flags
 419       (unless (elmo-global-flag-p (car flags))
 420         (setq result (delq (car flags) result)))
 421       (setq flags (cdr flags)))
 422     (when ignore-preserved
 423       (dolist (flag elmo-preserved-flags)
 424         (setq result (delq flag result))))
 425     result))
 426
 427 ;;; To migrate from global mark folder
 428 (defvar elmo-global-mark-filename "global-mark"
 429   "Obsolete variable. (Just for migration)")
 430
 431 (defun elmo-global-mark-migrate ()
 432   "Migrate from 'mark to 'flag. For automatic migration."
 433   (when (and (file-exists-p (expand-file-name elmo-global-mark-filename
 434                                               elmo-msgdb-directory))
 435              (elmo-global-flag-p 'important)
 436              (not (file-exists-p (elmo-folder-expand-msgdb-path
 437                                   (elmo-flag-get-folder 'important)))))
 438     (elmo-global-mark-upgrade)))
 439
 440 (defun elmo-global-mark-upgrade ()
 441   "Upgrade old `global-mark' structure."
 442   (interactive)
 443   (when (file-exists-p (expand-file-name
 444                         elmo-global-mark-filename elmo-msgdb-directory))
 445     (message "Upgrading flag structure...")
 446     (when (elmo-global-flag-p 'important)
 447       (let ((global-marks
 448              (elmo-object-load
 449               (expand-file-name
 450                elmo-global-mark-filename elmo-msgdb-directory)))
 451             (folder (elmo-flag-get-folder 'important))
 452             file-cache)
 453         (dolist (elem global-marks)
 454           (setq file-cache (elmo-file-cache-get (car elem)))
 455           (when (eq (elmo-file-cache-status file-cache) 'entire)
 456             (elmo-global-flag-set 'important nil nil (car elem))))))
 457     (message "Upgrading flag structure...done")))
 458
 459 (luna-define-method elmo-folder-delete :around ((folder elmo-flag-folder))
 460   (let ((flag (elmo-flag-folder-flag-internal folder)))
 461     (when (luna-call-next-method)
 462       (setq elmo-global-flags (delq flag elmo-global-flags))
 463       t)))
 464
 465 (require 'product)
 466 (product-provide (provide 'elmo-flag) (require 'elmo-version))
 467
 468 ;;; elmo-flag.el ends here