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