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