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