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 "#" (int-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 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-clear (location-map)
  96   (elmo-location-map-set-max-number location-map 0)
  97   (elmo-location-map-set-alist location-map nil)
  98   (elmo-location-map-set-hash location-map (elmo-make-hash)))
  99
 100 (defun elmo-location-map-update (location-map locations)
 101   "Update location alist in LOCATION-MAP by LOCATIONS.
 102 Return new location alist."
 103   (let ((old-hash (elmo-location-map-hash location-map))
 104         (new-hash (elmo-make-hash (length locations)))
 105         (number (elmo-location-map-max-number location-map))
 106         new-alist)
 107     (setq new-alist
 108           (mapcar
 109            (lambda (location)
 110              (let ((entry (or (elmo-get-hash-val location old-hash)
 111                               (cons (setq number (1+ number)) location))))
 112                (elmo-set-hash-val (elmo-location-map-key (car entry))
 113                                   entry
 114                                   new-hash)
 115                (elmo-set-hash-val location entry new-hash)
 116                entry))
 117            locations))
 118     (let ((inhibit-quit t))
 119       (elmo-location-map-set-max-number location-map number)
 120       (elmo-location-map-set-hash location-map new-hash)
 121       (elmo-location-map-set-alist location-map new-alist))))
 122
 123 (defun elmo-location-map-remove-numbers (location-map numbers)
 124   (let ((alist (elmo-location-map-alist location-map))
 125         (hash (elmo-location-map-hash location-map)))
 126     (dolist (number numbers)
 127       (let* ((key (elmo-location-map-key number))
 128              (entry (elmo-get-hash-val key hash))
 129              (inhibit-quit t))
 130         (elmo-location-map-set-alist
 131          location-map
 132          (setq alist (delq entry alist)))
 133         (elmo-clear-hash-val key hash)
 134         (elmo-clear-hash-val (cdr entry) hash)))))
 135
 136 (defun elmo-map-message-number (location-map location)
 137   "Return number of the message in the MAPPER with LOCATION."
 138   (car (elmo-get-hash-val
 139         location
 140         (elmo-location-map-hash location-map))))
 141
 142 (defun elmo-map-message-location (location-map number)
 143   "Return location of the message in the MAPPER with NUMBER."
 144   (cdr (elmo-get-hash-val
 145         (elmo-location-map-key number)
 146         (elmo-location-map-hash location-map))))
 147
 148 (defun elmo-map-numbers-to-locations (location-map numbers)
 149   (let (locations pair)
 150     (dolist (number numbers)
 151       (if (setq pair (elmo-get-hash-val
 152                       (elmo-location-map-key number)
 153                       (elmo-location-map-hash location-map)))
 154           (setq locations (cons (cdr pair) locations))))
 155     (nreverse locations)))
 156
 157 (defun elmo-map-locations-to-numbers (location-map locations)
 158   (let (numbers pair)
 159     (dolist (location locations)
 160       (if (setq pair (elmo-get-hash-val
 161                       location
 162                       (elmo-location-map-hash location-map)))
 163           (setq numbers (cons (car pair) numbers))))
 164     (nreverse numbers)))
 165
 166
 167 (eval-and-compile
 168   (luna-define-class elmo-map-folder (elmo-folder elmo-location-map))
 169   (luna-define-internal-accessors 'elmo-map-folder))
 170
 171 (luna-define-generic elmo-map-folder-list-message-locations (folder)
 172   "Return a location list of the FOLDER.")
 173
 174 (luna-define-generic elmo-map-folder-set-flag (folder locations flag)
 175   "Set FLAG to LOCATIONS.")
 176
 177 (luna-define-generic elmo-map-folder-unset-flag (folder locations flag)
 178   "Unset FLAG from LOCATIONS.")
 179
 180 (luna-define-generic elmo-map-message-fetch (folder location
 181                                                     strategy
 182                                                     &optional
 183                                                     section
 184                                                     unseen)
 185   "")
 186
 187 (luna-define-generic elmo-map-folder-delete-messages (folder locations)
 188   "")
 189
 190 (luna-define-method elmo-folder-status ((folder elmo-map-folder))
 191   (elmo-folder-open-internal folder)
 192   (elmo-folder-set-killed-list-internal
 193    folder
 194    (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder)))
 195   (let ((numbers (mapcar
 196                   'car
 197                   (elmo-location-map-alist folder))))
 198     (setq numbers (elmo-living-messages
 199                    numbers
 200                    (elmo-folder-killed-list-internal folder)))
 201     (prog1
 202         (cons (elmo-max-of-list numbers)
 203               (length numbers))
 204       ;; Don't close after status.
 205       (unless (elmo-folder-reserve-status-p folder)
 206         (elmo-folder-close-internal folder)))))
 207
 208 (luna-define-method elmo-folder-pack-numbers ((folder elmo-map-folder))
 209   (let* ((msgdb (elmo-folder-msgdb folder))
 210          (numbers
 211           (sort (elmo-folder-list-messages folder nil
 212                                            (not elmo-pack-number-check-strict))
 213                 '<))
 214          (new-msgdb (elmo-make-msgdb (elmo-folder-msgdb-path folder)))
 215          (number 1)
 216          total location entity)
 217     (setq total (length numbers))
 218     (elmo-with-progress-display (> total elmo-display-progress-threshold)
 219         (elmo-folder-pack-numbers total "Packing...")
 220       (dolist (old-number numbers)
 221         (setq entity (elmo-msgdb-message-entity msgdb old-number))
 222         (elmo-message-entity-set-number entity number)
 223         (elmo-msgdb-append-entity new-msgdb entity
 224                                   (elmo-msgdb-flags msgdb old-number))
 225         (setq location
 226               (cons (cons number
 227                           (elmo-map-message-location folder old-number))
 228                     location))
 229         (elmo-emit-signal 'message-number-changed folder old-number number)
 230         (setq number (1+ number))))
 231     (message "Packing...done")
 232     (elmo-location-map-setup folder (nreverse location))
 233     (elmo-folder-set-msgdb-internal folder new-msgdb)))
 234
 235 (luna-define-method elmo-folder-open-internal ((folder elmo-map-folder))
 236   (elmo-location-map-load folder (elmo-folder-msgdb-path folder))
 237   (when (elmo-folder-plugged-p folder)
 238     (elmo-location-map-update
 239      folder
 240      (elmo-map-folder-list-message-locations folder))))
 241
 242 (luna-define-method elmo-folder-commit :after ((folder elmo-map-folder))
 243   (when (elmo-folder-persistent-p folder)
 244     (elmo-location-map-save folder (elmo-folder-msgdb-path folder))))
 245
 246 (luna-define-method elmo-folder-close-internal ((folder elmo-map-folder))
 247   (elmo-location-map-teardown folder))
 248
 249 (luna-define-method elmo-folder-check ((folder elmo-map-folder))
 250   (elmo-location-map-update
 251    folder
 252    (elmo-map-folder-list-message-locations folder)))
 253
 254 (luna-define-method elmo-folder-next-message-number ((folder elmo-map-folder))
 255   (1+ (elmo-location-map-max-number folder)))
 256
 257 (luna-define-method elmo-folder-clear :around ((folder elmo-map-folder)
 258                                                &optional keep-killed)
 259   (unless keep-killed
 260     (elmo-location-map-clear folder))
 261   (luna-call-next-method))
 262
 263 (luna-define-method elmo-folder-list-messages-internal
 264   ((folder elmo-map-folder) &optional nohide)
 265   (mapcar 'car (elmo-location-map-alist folder)))
 266
 267 (luna-define-method elmo-folder-set-flag :before ((folder elmo-map-folder)
 268                                                   numbers
 269                                                   flag
 270                                                   &optional is-local)
 271   (unless is-local
 272     (elmo-map-folder-set-flag
 273      folder
 274      (elmo-map-numbers-to-locations folder numbers)
 275      flag)))
 276
 277 (luna-define-method elmo-folder-unset-flag :before ((folder elmo-map-folder)
 278                                                     numbers
 279                                                     flag
 280                                                     &optional is-local)
 281   (unless is-local
 282     (elmo-map-folder-unset-flag
 283      folder
 284      (elmo-map-numbers-to-locations folder numbers)
 285      flag)))
 286
 287 (luna-define-method elmo-message-fetch-internal ((folder elmo-map-folder)
 288                                                  number strategy
 289                                                  &optional section unread)
 290   (elmo-map-message-fetch
 291    folder
 292    (elmo-map-message-location folder number)
 293    strategy section unread))
 294
 295 (luna-define-method elmo-folder-list-flagged-internal ((folder elmo-map-folder)
 296                                                        flag)
 297   (let ((locations (elmo-map-folder-list-flagged folder flag)))
 298     (if (listp locations)
 299         (elmo-map-locations-to-numbers folder locations)
 300       t)))
 301
 302 (luna-define-generic elmo-map-folder-list-flagged (folder flag)
 303   "Return a list of message location in the FOLDER with FLAG.
 304 Return t if the message list is not available.")
 305
 306 (luna-define-method elmo-map-folder-list-flagged ((folder elmo-map-folder)
 307                                                   flag)
 308   t)
 309
 310 (luna-define-method elmo-folder-delete-messages-internal ((folder
 311                                                            elmo-map-folder)
 312                                                           numbers)
 313   (elmo-map-folder-delete-messages
 314    folder
 315    (elmo-map-numbers-to-locations folder numbers)))
 316
 317 (luna-define-method elmo-folder-detach-messages :around ((folder
 318                                                           elmo-map-folder)
 319                                                          numbers)
 320   (when (luna-call-next-method)
 321     (elmo-location-map-remove-numbers folder numbers)
 322     t)) ; success
 323
 324 (require 'product)
 325 (product-provide (provide 'elmo-map) (require 'elmo-version))
 326
 327 ;;; elmo-map.el ends here