elmo/elmo-map.el

   1 ;;; elmo-map.el --- A ELMO folder class with message number mapping.
   2
   3 ;; Copyright (C) 2000 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 ;; Folders which do not have unique message numbers but unique message names
  28 ;; should inherit this folder.
  29
  30 ;;; Code:
  31 ;;
  32 (require 'elmo)
  33 (require 'elmo-msgdb)
  34
  35 (eval-when-compile (require 'cl))
  36
  37 (eval-and-compile
  38   (luna-define-class elmo-location-map ()
  39                      (location-alist location-hash max-number)))
  40
  41 (defmacro elmo-location-map-alist (entity)
  42   `(luna-slot-value ,entity 'location-alist))
  43
  44 (defmacro elmo-location-map-set-alist (entity value)
  45   `(luna-set-slot-value ,entity 'location-alist ,value))
  46
  47 (defmacro elmo-location-map-hash (entity)
  48   `(luna-slot-value ,entity 'location-hash))
  49
  50 (defmacro elmo-location-map-set-hash (entity value)
  51   `(luna-set-slot-value ,entity 'location-hash ,value))
  52
  53 (defmacro elmo-location-map-max-number (entity)
  54   `(luna-slot-value ,entity 'max-number))
  55
  56 (defmacro elmo-location-map-set-max-number (entity value)
  57   `(luna-set-slot-value ,entity 'max-number ,value))
  58
  59
  60 (defmacro elmo-location-map-key (number)
  61   `(concat "#" (number-to-string ,number)))
  62
  63 (defun elmo-location-map-load (location-map directory)
  64   (elmo-location-map-setup
  65    location-map
  66    (elmo-msgdb-location-load directory)))
  67
  68 (defun elmo-location-map-save (location-map directory)
  69   (let ((alist (elmo-location-map-alist location-map)))
  70     (elmo-msgdb-location-save
  71      directory
  72      (cons (cons (elmo-location-map-max-number location-map) nil)
  73            alist))))
  74
  75 (defun elmo-location-map-setup (location-map &optional locations)
  76   "Setup internal data of LOCATION-MAP by LOCATIONS.
  77 Return a location alist."
  78   (let ((hash (elmo-make-hash (length locations)))
  79         (max-number 0))
  80     ;; Set number-max and hashtables.
  81     (dolist (pair locations)
  82       (setq max-number (max max-number (car pair)))
  83       (when (cdr pair)
  84         (elmo-set-hash-val (cdr pair) pair hash)
  85         (elmo-set-hash-val (elmo-location-map-key (car pair)) pair hash)))
  86     (let ((inhibit-quit t))
  87       (elmo-location-map-set-max-number location-map max-number)
  88       (elmo-location-map-set-hash location-map hash)
  89       (elmo-location-map-set-alist location-map locations))))
  90
  91 (defun elmo-location-map-teardown (location-map)
  92   (elmo-location-map-set-alist location-map nil)
  93   (elmo-location-map-set-hash location-map nil))
  94
  95 (defun elmo-location-map-update (location-map locations)
  96   "Update location alist in LOCATION-MAP by LOCATIONS.
  97 Return new location alist."
  98   (let ((old-hash (elmo-location-map-hash location-map))
  99         (new-hash (elmo-make-hash (length locations)))
 100         (number (elmo-location-map-max-number location-map))
 101         new-alist)
 102     (setq new-alist
 103           (mapcar
 104            (lambda (location)
 105              (let ((entry (or (elmo-get-hash-val location old-hash)
 106                               (cons (setq number (1+ number)) location))))
 107                (elmo-set-hash-val (elmo-location-map-key (car entry))
 108                                   entry
 109                                   new-hash)
 110                (elmo-set-hash-val location entry new-hash)
 111                entry))
 112            locations))
 113     (let ((inhibit-quit t))
 114       (elmo-location-map-set-max-number location-map number)
 115       (elmo-location-map-set-hash location-map new-hash)
 116       (elmo-location-map-set-alist location-map new-alist))))
 117
 118 (defun elmo-location-map-remove-numbers (location-map numbers)
 119   (let ((alist (elmo-location-map-alist location-map))
 120         (hash (elmo-location-map-hash location-map)))
 121     (dolist (number numbers)
 122       (let* ((key (elmo-location-map-key number))
 123              (entry (elmo-get-hash-val key hash))
 124              (inhibit-quit t))
 125         (elmo-location-map-set-alist
 126          location-map
 127          (setq alist (delq entry alist)))
 128         (elmo-clear-hash-val key hash)
 129         (elmo-clear-hash-val (cdr entry) hash)))))
 130
 131 (defun elmo-map-message-number (location-map location)
 132   "Return number of the message in the MAPPER with LOCATION."
 133   (car (elmo-get-hash-val
 134         location
 135         (elmo-location-map-hash location-map))))
 136
 137 (defun elmo-map-message-location (location-map number)
 138   "Return location of the message in the MAPPER with NUMBER."
 139   (cdr (elmo-get-hash-val
 140         (elmo-location-map-key number)
 141         (elmo-location-map-hash location-map))))
 142
 143 (defun elmo-map-numbers-to-locations (location-map numbers)
 144   (let (locations pair)
 145     (dolist (number numbers)
 146       (if (setq pair (elmo-get-hash-val
 147                       (elmo-location-map-key number)
 148                       (elmo-location-map-hash location-map)))
 149           (setq locations (cons (cdr pair) locations))))
 150     (nreverse locations)))
 151
 152 (defun elmo-map-locations-to-numbers (location-map locations)
 153   (let (numbers pair)
 154     (dolist (location locations)
 155       (if (setq pair (elmo-get-hash-val
 156                       location
 157                       (elmo-location-map-hash location-map)))
 158           (setq numbers (cons (car pair) numbers))))
 159     (nreverse numbers)))
 160
 161
 162 (eval-and-compile
 163   (luna-define-class elmo-map-folder (elmo-folder elmo-location-map))
 164   (luna-define-internal-accessors 'elmo-map-folder))
 165
 166 (luna-define-generic elmo-map-folder-list-message-locations (folder)
 167   "Return a location list of the FOLDER.")
 168
 169 (luna-define-generic elmo-map-folder-set-flag (folder locations flag)
 170   "Set FLAG to LOCATIONS.")
 171
 172 (luna-define-generic elmo-map-folder-unset-flag (folder locations flag)
 173   "Unset FLAG from LOCATIONS.")
 174
 175 (luna-define-generic elmo-map-message-fetch (folder location
 176                                                     strategy
 177                                                     &optional
 178                                                     section
 179                                                     unseen)
 180   "")
 181
 182 (luna-define-generic elmo-map-folder-delete-messages (folder locations)
 183   "")
 184
 185 (luna-define-method elmo-folder-status ((folder elmo-map-folder))
 186   (elmo-folder-open-internal folder)
 187   (elmo-folder-set-killed-list-internal
 188    folder
 189    (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder)))
 190   (let ((numbers (mapcar
 191                   'car
 192                   (elmo-location-map-alist folder))))
 193     (setq numbers (elmo-living-messages
 194                    numbers
 195                    (elmo-folder-killed-list-internal folder)))
 196     (prog1
 197         (cons (elmo-max-of-list numbers)
 198               (length numbers))
 199       ;; Don't close after status.
 200       (unless (elmo-folder-reserve-status-p folder)
 201         (elmo-folder-close-internal folder)))))
 202
 203 (luna-define-method elmo-folder-pack-numbers ((folder elmo-map-folder))
 204   (let* ((msgdb (elmo-folder-msgdb folder))
 205          (numbers
 206           (sort (elmo-folder-list-messages folder nil
 207                                            (not elmo-pack-number-check-strict))
 208                 '<))
 209          (new-msgdb (elmo-make-msgdb (elmo-folder-msgdb-path folder)))
 210          (number 1)
 211          location entity)
 212     (elmo-with-progress-display (elmo-folder-pack-numbers (length numbers))
 213         "Packing"
 214       (dolist (old-number numbers)
 215         (setq entity (elmo-msgdb-message-entity msgdb old-number))
 216         (elmo-message-entity-set-number entity number)
 217         (elmo-msgdb-append-entity new-msgdb entity
 218                                   (elmo-msgdb-flags msgdb old-number))
 219         (setq location
 220               (cons (cons number
 221                           (elmo-map-message-location folder old-number))
 222                     location))
 223         (elmo-emit-signal 'message-number-changed folder old-number number)
 224         (setq number (1+ number))))
 225     (message "Packing...done")
 226     (elmo-location-map-setup folder (nreverse location))
 227     (elmo-folder-set-msgdb-internal folder new-msgdb)))
 228
 229 (luna-define-method elmo-folder-open-internal ((folder elmo-map-folder))
 230   (elmo-location-map-load folder (elmo-folder-msgdb-path folder))
 231   (when (elmo-folder-plugged-p folder)
 232     (elmo-location-map-update
 233      folder
 234      (elmo-map-folder-list-message-locations folder))))
 235
 236 (luna-define-method elmo-folder-commit :after ((folder elmo-map-folder))
 237   (when (elmo-folder-persistent-p folder)
 238     (elmo-location-map-save folder (elmo-folder-msgdb-path folder))))
 239
 240 (luna-define-method elmo-folder-close-internal ((folder elmo-map-folder))
 241   (elmo-location-map-teardown folder))
 242
 243 (luna-define-method elmo-folder-check ((folder elmo-map-folder))
 244   (elmo-location-map-update
 245    folder
 246    (elmo-map-folder-list-message-locations folder)))
 247
 248 (luna-define-method elmo-folder-next-message-number ((folder elmo-map-folder))
 249   (1+ (elmo-location-map-max-number folder)))
 250
 251 (luna-define-method elmo-folder-clear :around ((folder elmo-map-folder)
 252                                                &optional keep-killed)
 253   (unless keep-killed
 254     (elmo-location-map-setup folder))
 255   (luna-call-next-method))
 256
 257 (luna-define-method elmo-folder-list-messages-internal
 258   ((folder elmo-map-folder) &optional nohide)
 259   (mapcar 'car (elmo-location-map-alist folder)))
 260
 261 (luna-define-method elmo-folder-set-flag :before ((folder elmo-map-folder)
 262                                                   numbers
 263                                                   flag
 264                                                   &optional is-local)
 265   (unless is-local
 266     (elmo-map-folder-set-flag
 267      folder
 268      (elmo-map-numbers-to-locations folder numbers)
 269      flag)))
 270
 271 (luna-define-method elmo-folder-unset-flag :before ((folder elmo-map-folder)
 272                                                     numbers
 273                                                     flag
 274                                                     &optional is-local)
 275   (unless is-local
 276     (elmo-map-folder-unset-flag
 277      folder
 278      (elmo-map-numbers-to-locations folder numbers)
 279      flag)))
 280
 281 (luna-define-method elmo-message-fetch-internal ((folder elmo-map-folder)
 282                                                  number strategy
 283                                                  &optional section unread)
 284   (elmo-map-message-fetch
 285    folder
 286    (elmo-map-message-location folder number)
 287    strategy section unread))
 288
 289 (luna-define-method elmo-folder-list-flagged-internal ((folder elmo-map-folder)
 290                                                        flag)
 291   (let ((locations (elmo-map-folder-list-flagged folder flag)))
 292     (if (listp locations)
 293         (elmo-map-locations-to-numbers folder locations)
 294       t)))
 295
 296 (luna-define-generic elmo-map-folder-list-flagged (folder flag)
 297   "Return a list of message location in the FOLDER with FLAG.
 298 Return t if the message list is not available.")
 299
 300 (luna-define-method elmo-map-folder-list-flagged ((folder elmo-map-folder)
 301                                                   flag)
 302   t)
 303
 304 (luna-define-method elmo-folder-delete-messages-internal ((folder
 305                                                            elmo-map-folder)
 306                                                           numbers)
 307   (elmo-map-folder-delete-messages
 308    folder
 309    (elmo-map-numbers-to-locations folder numbers)))
 310
 311 (luna-define-method elmo-folder-detach-messages :around ((folder
 312                                                           elmo-map-folder)
 313                                                          numbers)
 314   (when (luna-call-next-method)
 315     (elmo-location-map-remove-numbers folder numbers)
 316     t)) ; success
 317
 318 (require 'product)
 319 (product-provide (provide 'elmo-map) (require 'elmo-version))
 320
 321 ;;; elmo-map.el ends here