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
  29 ;;; Code:
  30 (require 'elmo-util)
  31 (require 'elmo-localdir)
  32 (eval-when-compile (require 'cl))
  33
  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)
  38
  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)
  43
  44 (defvar elmo-global-flag-folder-alist nil
  45   "Internal variable to hold global-flag-folder structures.")
  46
  47 (eval-and-compile
  48   (defconst elmo-flag-char-regexp "]!#$&'+,./0-9:;<=>?@A-Z[^_`a-z|}~-"))
  49
  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))))
  54
  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))
  59
  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)))
 103
 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)))
 116
 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))
 123
 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))))
 134
 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))
 141              "/"
 142              (symbol-name flag)))
 143           elmo-global-flags))
 144
 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))))
 173   t)
 174
 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)
 182   t)
 183
 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)))
 201
 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)
 213
 214 (luna-define-method elmo-folder-append-buffer ((folder elmo-flag-folder)
 215                                                &optional flag number)
 216   (error "Cannot append to the flag folder"))
 217
 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)))
 224
 225 ;;; Utilities
 226
 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)))))
 231
 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)))))
 242
 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))
 247
 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))
 263
 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)))
 275
 276 ;;;
 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)))
 287
 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))
 291
 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)))
 322             1))
 323         (setq new-file
 324               (expand-file-name
 325                (number-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))
 335          (t
 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)))
 366
 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)))
 375
 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
 392                     key
 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)))))))
 407
 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)))))
 419
 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)))))
 433
 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))
 451
 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))))
 468
 469 ;;; To migrate from global mark folder
 470 (defvar elmo-global-mark-filename "global-mark"
 471   "Obsolete variable. (Just for migration)")
 472
 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)))
 481
 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")))
 500
 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)))
 509
 510 (require 'product)
 511 (product-provide (provide 'elmo-flag) (require 'elmo-version))
 512
 513 ;;; elmo-flag.el ends here