cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-sort.el

   1 ;;; vm-sort.el ---  Sorting and moving messages inside VM
   2 ;; Copyright (C) 1993, 1994 Kyle E. Jones
   3 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   4 ;;
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2 of the License, or
   8 ;; (at your option) any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License along
  16 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  17 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  18
  19
  20 ;;; Commentary:
  21 ;;
  22
  23 ;;;###autoload
  24 (defun vm-move-message-forward (count)
  25   "Move a message forward in a VM folder.
  26 Prefix arg COUNT causes the current message to be moved COUNT messages forward.
  27 A negative COUNT causes movement to be backward instead of forward.
  28 COUNT defaults to 1.  The current message remains selected after being
  29 moved.
  30
  31 If vm-move-messages-physically is non-nil, the physical copy of
  32 the message in the folder is moved.  A nil value means just
  33 change the presentation order and leave the physical order of
  34 the folder undisturbed."
  35   (interactive "p")
  36   (vm-follow-summary-cursor)
  37   (vm-select-folder-buffer)
  38   (vm-check-for-killed-summary)
  39   (vm-error-if-folder-empty)
  40   (if vm-move-messages-physically
  41       (vm-error-if-folder-read-only))
  42   (vm-display nil nil '(vm-move-message-forward
  43                         vm-move-message-backward
  44                         vm-move-message-forward-physically
  45                         vm-move-message-backward-physically)
  46               (list this-command))
  47   (let* ((ovmp vm-message-pointer) vmp-prev ovmp-prev
  48          (vm-message-pointer vm-message-pointer)
  49          (direction (if (> count 0) 'forward 'backward))
  50          (count (vm-abs count)))
  51     (while (not (zerop count))
  52       (vm-move-message-pointer direction)
  53       (vm-decrement count))
  54     (if (> (string-to-number (vm-number-of (car vm-message-pointer)))
  55            (string-to-number (vm-number-of (car ovmp))))
  56         (setq vm-message-pointer (cdr vm-message-pointer)))
  57     (if (eq vm-message-pointer ovmp)
  58         ()
  59       (if (null vm-message-pointer)
  60           (setq vmp-prev (vm-last vm-message-list))
  61         (setq vmp-prev (vm-reverse-link-of (car vm-message-pointer))))
  62       (setq ovmp-prev (vm-reverse-link-of (car ovmp)))
  63       ;; lock out interrupts to preserve message list integrity.
  64       (let ((inhibit-quit t))
  65         (if ovmp-prev
  66             (progn
  67               (setcdr ovmp-prev (cdr ovmp))
  68               (and (cdr ovmp)
  69                    (vm-set-reverse-link-of (car (cdr ovmp)) ovmp-prev)))
  70           (setq vm-message-list (cdr ovmp))
  71           (vm-set-reverse-link-of (car vm-message-list) nil))
  72         (if vmp-prev
  73             (progn
  74               (setcdr vmp-prev ovmp)
  75               (vm-set-reverse-link-of (car ovmp) vmp-prev))
  76           (setq vm-message-list ovmp)
  77           (vm-set-reverse-link-of (car vm-message-list) nil))
  78         (setcdr ovmp vm-message-pointer)
  79         (and vm-message-pointer
  80              (vm-set-reverse-link-of (car vm-message-pointer) ovmp))
  81         (if (and vm-move-messages-physically
  82                  (not (eq major-mode 'vm-virtual-mode)))
  83             (vm-physically-move-message (car ovmp) (car vm-message-pointer)))
  84         (setq vm-ml-sort-keys nil)
  85         (if (not vm-folder-read-only)
  86             (progn
  87               (setq vm-message-order-changed t)
  88               (vm-set-buffer-modified-p t)
  89               (vm-clear-modification-flag-undos))))
  90       (cond ((null ovmp-prev)
  91              (setq vm-numbering-redo-start-point vm-message-list
  92                    vm-numbering-redo-end-point vm-message-pointer
  93                    vm-summary-pointer (car vm-message-list)))
  94             ((null vmp-prev)
  95              (setq vm-numbering-redo-start-point vm-message-list
  96                    vm-numbering-redo-end-point (cdr ovmp-prev)
  97                    vm-summary-pointer (car ovmp-prev)))
  98             ((or (not vm-message-pointer)
  99                  (< (string-to-number (vm-number-of (car ovmp-prev)))
 100                     (string-to-number (vm-number-of (car vm-message-pointer)))))
 101              (setq vm-numbering-redo-start-point (cdr ovmp-prev)
 102                    vm-numbering-redo-end-point (cdr ovmp)
 103                    vm-summary-pointer (car (cdr ovmp-prev))))
 104             (t
 105              (setq vm-numbering-redo-start-point ovmp
 106                    vm-numbering-redo-end-point (cdr ovmp-prev)
 107                    vm-summary-pointer (car ovmp-prev))))
 108       (if vm-summary-buffer
 109           (let (list mp)
 110             (vm-copy-local-variables vm-summary-buffer 'vm-summary-pointer)
 111             (setq vm-need-summary-pointer-update t)
 112             (setq mp vm-numbering-redo-start-point)
 113             (while (not (eq mp vm-numbering-redo-end-point))
 114               (vm-mark-for-summary-update (car mp))
 115               (setq list (cons (car mp) list)
 116                     mp (cdr mp)))
 117             (vm-mapc
 118              (function
 119               (lambda (m p)
 120                 (vm-set-su-start-of m (car p))
 121                 (vm-set-su-end-of m (car (cdr p)))))
 122              (setq list (nreverse list))
 123              (sort
 124               (mapcar
 125                (function
 126                 (lambda (p)
 127                   (list (vm-su-start-of p) (vm-su-end-of p))))
 128                list)
 129               (function
 130                (lambda (p q)
 131                  (< (car p) (car q))))))))))
 132   (if vm-move-messages-physically
 133       ;; clip region is messed up
 134       (vm-preview-current-message)
 135     (vm-update-summary-and-mode-line)))
 136
 137 ;;;###autoload
 138 (defun vm-move-message-backward (count)
 139   "Move a message backward in a VM folder.
 140 Prefix arg COUNT causes the current message to be moved COUNT
 141 messages backward.  A negative COUNT causes movement to be
 142 forward instead of backward.  COUNT defaults to 1.  The current
 143 message remains selected after being moved.
 144
 145 If vm-move-messages-physically is non-nil, the physical copy of
 146 the message in the folder is moved.  A nil value means just
 147 change the presentation order and leave the physical order of
 148 the folder undisturbed."
 149   (interactive "p")
 150   (vm-move-message-forward (- count)))
 151
 152 ;;;###autoload
 153 (defun vm-move-message-forward-physically (count)
 154   "Like vm-move-message-forward but always move the message physically."
 155   (interactive "p")
 156   (let ((vm-move-messages-physically t))
 157     (vm-move-message-forward count)))
 158
 159 ;;;###autoload
 160 (defun vm-move-message-backward-physically (count)
 161   "Like vm-move-message-backward but always move the message physically."
 162   (interactive "p")
 163   (let ((vm-move-messages-physically t))
 164     (vm-move-message-backward count)))
 165
 166 ;; move message m to be before m-dest
 167 ;; and fix up the location markers afterwards.
 168 ;; m better not equal m-dest.
 169 ;; of m-dest is nil, move m to the end of buffer.
 170 ;;
 171 ;; consider carefully the effects of insertion on markers
 172 ;; and variables containg markers before you modify this code.
 173 (defun vm-physically-move-message (m m-dest)
 174   (save-excursion
 175     (vm-save-restriction
 176      (widen)
 177
 178      ;; Make sure vm-headers-of and vm-text-of are non-nil in
 179      ;; their slots before we try to move them.  (Simply
 180      ;; referencing the slot with their slot function is
 181      ;; sufficient to guarantee this.)  Otherwise, they be
 182      ;; initialized in the middle of the message move and get the
 183      ;; offset applied to them twice by way of a relative offset
 184      ;; from one of the other location markers that has already
 185      ;; been moved.
 186      ;;
 187      ;; Also, and more importantly, vm-vheaders-of might run
 188      ;; vm-reorder-message-headers, which can add text to
 189      ;; message.  This MUST NOT happen after offsets have been
 190      ;; computed for the message move or varying levels of chaos
 191      ;; will ensue.  In the case of BABYL files, where
 192      ;; vm-reorder-message-headers can add a lot of new text,
 193      ;; folder curroption can be massive.
 194      (vm-text-of m)
 195      (vm-vheaders-of m)
 196
 197      (let ((dest-start (if m-dest (vm-start-of m-dest) (point-max)))
 198            (buffer-read-only nil)
 199            offset doomed-start doomed-end)
 200        (goto-char dest-start)
 201        (insert-buffer-substring (current-buffer) (vm-start-of m) (vm-end-of m))
 202        (setq doomed-start (marker-position (vm-start-of m))
 203              doomed-end (marker-position (vm-end-of m))
 204              offset (- (vm-start-of m) dest-start))
 205        (set-marker (vm-start-of m) (- (vm-start-of m) offset))
 206        (set-marker (vm-headers-of m) (- (vm-headers-of m) offset))
 207        (set-marker (vm-text-end-of m) (- (vm-text-end-of m) offset))
 208        (set-marker (vm-end-of m) (- (vm-end-of m) offset))
 209        (set-marker (vm-text-of m) (- (vm-text-of m) offset))
 210        (set-marker (vm-vheaders-of m) (- (vm-vheaders-of m) offset))
 211        ;; now fix the start of m-dest since it didn't
 212        ;; move forward with its message.
 213        (and m-dest (set-marker (vm-start-of m-dest) (vm-end-of m)))
 214        ;; delete the old copy of the message
 215        (delete-region doomed-start doomed-end)))))
 216
 217 ;;;###autoload
 218 (defun vm-so-sortable-datestring (m)
 219   (or (vm-sortable-datestring-of m)
 220       (progn
 221         (vm-set-sortable-datestring-of
 222          m
 223          (condition-case nil
 224              (vm-timezone-make-date-sortable
 225               (or (vm-get-header-contents m "Date:")
 226                   (vm-grok-From_-date m)
 227                   "Thu, 1 Jan 1970 00:00:00 GMT"))
 228            (error "1970010100:00:00")))
 229         (vm-sortable-datestring-of m))))
 230
 231 ;;;###autoload
 232 (defun vm-so-sortable-subject (m)
 233   (or (vm-sortable-subject-of m)
 234       (progn
 235         (vm-set-sortable-subject-of
 236          m
 237          (let ((case-fold-search t)
 238                (subject (vm-su-subject m)))
 239            (if (and vm-subject-ignored-prefix
 240                     (string-match vm-subject-ignored-prefix subject)
 241                     (zerop (match-beginning 0)))
 242                (setq subject (substring subject (match-end 0))))
 243            (if (and vm-subject-ignored-suffix
 244                     (string-match vm-subject-ignored-suffix subject)
 245                     (= (match-end 0) (length subject)))
 246                (setq subject (substring subject 0 (match-beginning 0))))
 247            (setq subject (vm-with-string-as-temp-buffer
 248                           subject
 249                           (function vm-collapse-whitespace)))
 250            (if (and vm-subject-significant-chars
 251                     (natnump vm-subject-significant-chars)
 252                     (< vm-subject-significant-chars (length subject)))
 253                (setq subject
 254                      (substring subject 0 vm-subject-significant-chars)))
 255            subject ))
 256         (vm-sortable-subject-of m))))
 257
 258 (defvar vm-sort-compare-header nil
 259   "the header to sort on.")
 260
 261 (defvar vm-sort-compare-header-history nil)
 262
 263 ;;;###autoload
 264 (defun vm-sort-messages (keys &optional lets-get-physical)
 265   "Sort message in a folder by the specified KEYS.
 266 You may sort by more than one particular message key.  If
 267 messages compare equal by the first key, the second key will be
 268 compared and so on.  When called interactively the keys will be
 269 read from the minibuffer.  Valid keys are
 270
 271 \"date\"                \"reversed-date\"
 272 \"author\"              \"reversed-author\"
 273 \"full-name\"           \"reversed-full-name\"
 274 \"subject\"             \"reversed-subject\"
 275 \"recipients\"          \"reversed-recipients\"
 276 \"line-count\"          \"reversed-line-count\"
 277 \"byte-count\"          \"reversed-byte-count\"
 278 \"physical-order\"      \"reversed-physical-order\"
 279 \"spam-score\"          \"reversed-spam-score\"
 280
 281 Optional second arg (prefix arg interactively) means the sort
 282 should change the physical order of the messages in the folder.
 283 Normally VM changes presentation order only, leaving the
 284 folder in the order in which the messages arrived."
 285   (interactive
 286    (let ((last-command last-command)
 287          (this-command this-command))
 288    (list (vm-read-string (if (or current-prefix-arg
 289                                  vm-move-messages-physically)
 290                              "Physically sort messages by: "
 291                            "Sort messages by: ")
 292                          vm-supported-sort-keys t)
 293          current-prefix-arg)))
 294   (vm-select-folder-buffer)
 295   (vm-check-for-killed-summary)
 296   ;; only squawk if interactive.  The thread display uses this
 297   ;; function and doesn't expect errors.
 298   (if (interactive-p)
 299       (vm-error-if-folder-empty))
 300   ;; ditto
 301   (if (and (interactive-p) (or vm-move-messages-physically lets-get-physical))
 302       (vm-error-if-folder-read-only))
 303
 304   (vm-display nil nil '(vm-sort-messages) '(vm-sort-messages))
 305   (let (key-list key-funcs key ml-keys
 306         physical-order-list old-message-list new-message-list mp-old mp-new
 307         old-start
 308         doomed-start doomed-end offset
 309         (order-did-change nil)
 310         virtual
 311         physical
 312         auto-folder-p)
 313     (setq key-list (vm-parse keys "[ \t]*\\([^ \t]+\\)")
 314           ml-keys (and key-list (mapconcat (function identity) key-list "/"))
 315           key-funcs nil
 316           old-message-list vm-message-list
 317           virtual (eq major-mode 'vm-virtual-mode)
 318           physical (and (or lets-get-physical
 319                             vm-move-messages-physically)
 320                         (not vm-folder-read-only)
 321                         (not virtual)))
 322     (or key-list (error "No sort keys specified."))
 323     (while key-list
 324       (setq key (car key-list))
 325       (cond ((equal key "thread")
 326              (vm-build-threads-if-unbuilt)
 327              (vm-build-thread-lists)
 328              (setq key-funcs (cons 'vm-sort-compare-thread key-funcs)))
 329             ((equal key "auto-folder")
 330              (setq auto-folder-p t)
 331              (setq key-funcs (cons 'vm-sort-compare-auto-folder key-funcs)))
 332             ((equal key "author")
 333              (setq key-funcs (cons 'vm-sort-compare-author key-funcs)))
 334             ((equal key "reversed-author")
 335              (setq key-funcs (cons 'vm-sort-compare-author-r key-funcs)))
 336             ((equal key "full-name")
 337              (setq key-funcs (cons 'vm-sort-compare-full-name key-funcs)))
 338             ((equal key "reversed-full-name")
 339              (setq key-funcs (cons 'vm-sort-compare-full-name-r key-funcs)))
 340             ((equal key "date")
 341              (setq key-funcs (cons 'vm-sort-compare-date key-funcs)))
 342             ((equal key "reversed-date")
 343              (setq key-funcs (cons 'vm-sort-compare-date-r key-funcs)))
 344             ((equal key "subject")
 345              (setq key-funcs (cons 'vm-sort-compare-subject key-funcs)))
 346             ((equal key "reversed-subject")
 347              (setq key-funcs (cons 'vm-sort-compare-subject-r key-funcs)))
 348             ((equal key "recipients")
 349              (setq key-funcs (cons 'vm-sort-compare-recipients key-funcs)))
 350             ((equal key "reversed-recipients")
 351              (setq key-funcs (cons 'vm-sort-compare-recipients-r key-funcs)))
 352             ((equal key "byte-count")
 353              (setq key-funcs (cons 'vm-sort-compare-byte-count key-funcs)))
 354             ((equal key "reversed-byte-count")
 355              (setq key-funcs (cons 'vm-sort-compare-byte-count-r key-funcs)))
 356             ((equal key "line-count")
 357              (setq key-funcs (cons 'vm-sort-compare-line-count key-funcs)))
 358             ((equal key "reversed-line-count")
 359              (setq key-funcs (cons 'vm-sort-compare-line-count-r key-funcs)))
 360             ((equal key "spam-score")
 361              (setq key-funcs (cons 'vm-sort-compare-spam-score key-funcs)))
 362             ((equal key "reversed-spam-score")
 363              (setq key-funcs (cons 'vm-sort-compare-spam-score-r key-funcs)))
 364             ((equal key "physical-order")
 365              (setq key-funcs (cons 'vm-sort-compare-physical-order key-funcs)))
 366             ((equal key "reversed-physical-order")
 367              (setq key-funcs (cons 'vm-sort-compare-physical-order-r key-funcs)))
 368             ((equal key "header")
 369              (setq vm-sort-compare-header nil)
 370              (setq key-funcs (cons 'vm-sort-compare-header key-funcs)))
 371             (t
 372              (let ((compare (intern (format "vm-sort-compare-%s" key))))
 373                (if (functionp compare)
 374                    (setq key-funcs (cons compare key-funcs))
 375                  (error "Unknown key: %s" key)))))
 376       (setq key-list (cdr key-list)))
 377     ;; if this is not a thread sort and threading is enabled,
 378     ;; then disable threading and make sure the whole summary is
 379     ;; regenerated (to recalculate %I everywhere).
 380     (if (and vm-summary-show-threads
 381              (not (equal key-funcs '(vm-sort-compare-thread))))
 382         (progn
 383           (setq vm-summary-show-threads nil)
 384           (vm-set-summary-redo-start-point t)))
 385     (message "Sorting...")
 386     (let ((vm-key-functions (nreverse key-funcs)))
 387       (setq new-message-list (sort (copy-sequence old-message-list)
 388                                    'vm-sort-compare-xxxxxx))
 389       ;; only need to do this sort if we're going to physically
 390       ;; move messages later.
 391       (if physical
 392           (setq vm-key-functions '(vm-sort-compare-physical-order)
 393                 physical-order-list (sort (copy-sequence old-message-list)
 394                                           'vm-sort-compare-xxxxxx))))
 395     (message "Sorting... done")
 396     (let ((inhibit-quit t))
 397       (setq mp-old old-message-list
 398             mp-new new-message-list)
 399       (while mp-new
 400         (if (eq (car mp-old) (car mp-new))
 401             (setq mp-old (cdr mp-old)
 402                   mp-new (cdr mp-new))
 403           (setq order-did-change t)
 404           ;; unless a full redo has been requested, the numbering
 405           ;; start point now points to a cons in the old message
 406           ;; list.  therefore we just change the variable
 407           ;; directly to avoid the list scan that
 408           ;; vm-set-numbering-redo-start-point does.
 409           (cond ((not (eq vm-numbering-redo-start-point t))
 410                  (setq vm-numbering-redo-start-point mp-new
 411                        vm-numbering-redo-end-point nil)))
 412           (if vm-summary-buffer
 413               (progn
 414                 (setq vm-need-summary-pointer-update t)
 415                 ;; same logic as numbering reset above...
 416                 (cond ((not (eq vm-summary-redo-start-point t))
 417                        (setq vm-summary-redo-start-point mp-new)))
 418                 ;; start point of this message's summary is now
 419                 ;; wrong relative to where it is in the
 420                 ;; message list.  fix it and the summary rebuild
 421                 ;; will take care of the rest.
 422                 (vm-set-su-start-of (car mp-new)
 423                                     (vm-su-start-of (car mp-old)))))
 424           (setq mp-new nil)))
 425       (if (and physical (vm-has-message-order))
 426           (let ((buffer-read-only nil))
 427             ;; the folder is being physically ordered so we don't
 428             ;; need a message order header to be stuffed, nor do
 429             ;; we need to retain one in the folder buffer.  so we
 430             ;; strip out any existing message order header and
 431             ;; say there are no changes to prevent a message
 432             ;; order header from being stuffed later.
 433             (vm-remove-message-order)
 434             (setq vm-message-order-changed nil)
 435             (message "Moving messages... ")
 436             (widen)
 437             (setq mp-old physical-order-list
 438                   mp-new new-message-list)
 439             (setq old-start (vm-start-of (car mp-old)))
 440             (while mp-new
 441               (if (< (vm-start-of (car mp-old)) old-start)
 442                   ;; already moved this message
 443                   (setq mp-old (cdr mp-old))
 444                 (if (eq (car mp-old) (car mp-new))
 445                     (setq mp-old (cdr mp-old)
 446                           mp-new (cdr mp-new))
 447                   ;; move message
 448                   (vm-physically-move-message (car mp-new) (car mp-old))
 449                   ;; record start position.  if vm-start-of
 450                   ;; mp-old ever becomes less than old-start
 451                   ;; we're running into messages that have
 452                   ;; already been moved.
 453                   (setq old-start (vm-start-of (car mp-old)))
 454                   ;; move mp-new but not mp-old because we moved
 455                   ;; mp-old down one message by inserting a
 456                   ;; message in front of it.
 457                   (setq mp-new (cdr mp-new)))))
 458             (message "Moving messages... done")
 459             (vm-set-buffer-modified-p t)
 460             (vm-clear-modification-flag-undos))
 461         (if (and order-did-change (not vm-folder-read-only))
 462             (progn
 463               (setq vm-message-order-changed t)
 464               (vm-set-buffer-modified-p t)
 465               (vm-clear-modification-flag-undos))))
 466       (setq vm-ml-sort-keys ml-keys)
 467       (intern (buffer-name) vm-buffers-needing-display-update)
 468       (cond (order-did-change
 469              (setq vm-message-list new-message-list)
 470              (vm-reverse-link-messages)
 471              (if vm-message-pointer
 472                  (setq vm-message-pointer
 473                        (or (cdr (vm-reverse-link-of (car vm-message-pointer)))
 474                            vm-message-list)))
 475              (if vm-last-message-pointer
 476                  (setq vm-last-message-pointer
 477                        (or (cdr (vm-reverse-link-of
 478                                  (car vm-last-message-pointer)))
 479                            vm-message-list))))))
 480     (if (and vm-message-pointer
 481              order-did-change
 482              (or lets-get-physical vm-move-messages-physically))
 483         ;; clip region is most likely messed up
 484         (vm-preview-current-message)
 485       (vm-update-summary-and-mode-line))
 486
 487     (if auto-folder-p
 488         (vm-sort-insert-auto-folder-names))))
 489
 490 ;;;###autoload
 491 (defun vm-sort-compare-xxxxxx (m1 m2)
 492   (let ((key-funcs vm-key-functions) result)
 493     (while (and key-funcs
 494                 (eq '= (setq result (funcall (car key-funcs) m1 m2))))
 495       (setq key-funcs (cdr key-funcs)))
 496     (and key-funcs result) ))
 497
 498 (defun vm-sort-compare-thread (m1 m2)
 499   (let ((list1 (vm-th-thread-list m1))
 500         (list2 (vm-th-thread-list m2))
 501         p1 p2 d1 d2)
 502     (catch 'done
 503       (if (not (eq (car list1) (car list2)))
 504           (let ((date1 (get (car list1) 'youngest-date))
 505                 (date2 (get (car list2) 'youngest-date)))
 506             (cond ((string-lessp date1 date2) t)
 507                   ((string-equal date1 date2)
 508                    (string-lessp (car list1) (car list2)))
 509                   (t nil)))
 510         (setq list1 (cdr list1) list2 (cdr list2))
 511         (while (and list1 list2)
 512           (setq p1 (car list1) p2 (car list2))
 513           (cond ((not (string-equal p1 p2))
 514                  (setq d1 (or (get p1 'date) "0") d2 (or (get p2 'date) "0"))
 515                  (cond ((string-lessp d1 d2)
 516                         (throw 'done t))
 517                        ((string-lessp d2 d1)
 518                         (throw 'done nil))
 519                        ((string-lessp p1 p2)
 520                         (throw 'done t))
 521                        (t
 522                         (throw 'done t)))))
 523           (setq list1 (cdr list1)
 524                 list2 (cdr list2)))
 525         (cond ((and list1 (not list2)) nil)
 526               ((and list2 (not list1)) t)
 527               (t '=))))))
 528
 529 (defun vm-sort-compare-author (m1 m2)
 530   (let ((s1 (vm-su-from m1))
 531         (s2 (vm-su-from m2)))
 532     (cond ((string-lessp s1 s2) t)
 533           ((string-equal s1 s2) '=)
 534           (t nil))))
 535
 536 (defun vm-sort-compare-author-r (m1 m2)
 537   (let ((s1 (vm-su-from m1))
 538         (s2 (vm-su-from m2)))
 539     (cond ((string-lessp s1 s2) nil)
 540           ((string-equal s1 s2) '=)
 541           (t t))))
 542
 543 (defun vm-sort-compare-full-name (m1 m2)
 544   (let ((s1 (vm-su-full-name m1))
 545         (s2 (vm-su-full-name m2)))
 546     (cond ((string-lessp s1 s2) t)
 547           ((string-equal s1 s2) '=)
 548           (t nil))))
 549
 550 (defun vm-sort-compare-full-name-r (m1 m2)
 551   (let ((s1 (vm-su-full-name m1))
 552         (s2 (vm-su-full-name m2)))
 553     (cond ((string-lessp s1 s2) nil)
 554           ((string-equal s1 s2) '=)
 555           (t t))))
 556
 557 (defun vm-sort-compare-date (m1 m2)
 558   (let ((s1 (vm-so-sortable-datestring m1))
 559         (s2 (vm-so-sortable-datestring m2)))
 560     (cond ((string-lessp s1 s2) t)
 561           ((string-equal s1 s2) '=)
 562           (t nil))))
 563
 564 (defun vm-sort-compare-date-r (m1 m2)
 565   (let ((s1 (vm-so-sortable-datestring m1))
 566         (s2 (vm-so-sortable-datestring m2)))
 567     (cond ((string-lessp s1 s2) nil)
 568           ((string-equal s1 s2) '=)
 569           (t t))))
 570
 571 (defun vm-sort-compare-recipients (m1 m2)
 572   (let ((s1 (vm-su-to m1))
 573         (s2 (vm-su-to m2)))
 574     (cond ((string-lessp s1 s2) t)
 575           ((string-equal s1 s2) '=)
 576           (t nil))))
 577
 578 (defun vm-sort-compare-recipients-r (m1 m2)
 579   (let ((s1 (vm-su-to m1))
 580         (s2 (vm-su-to m2)))
 581     (cond ((string-lessp s1 s2) nil)
 582           ((string-equal s1 s2) '=)
 583           (t t))))
 584
 585 (defun vm-sort-compare-subject (m1 m2)
 586   (let ((s1 (vm-so-sortable-subject m1))
 587         (s2 (vm-so-sortable-subject m2)))
 588     (cond ((string-lessp s1 s2) t)
 589           ((string-equal s1 s2) '=)
 590           (t nil))))
 591
 592 (defun vm-sort-compare-subject-r (m1 m2)
 593   (let ((s1 (vm-so-sortable-subject m1))
 594         (s2 (vm-so-sortable-subject m2)))
 595     (cond ((string-lessp s1 s2) nil)
 596           ((string-equal s1 s2) '=)
 597           (t t))))
 598
 599 (defun vm-sort-compare-line-count (m1 m2)
 600   (let ((n1 (string-to-number (vm-su-line-count m1)))
 601         (n2 (string-to-number (vm-su-line-count m2))))
 602     (cond ((< n1 n2) t)
 603           ((= n1 n2) '=)
 604           (t nil))))
 605
 606 (defun vm-sort-compare-line-count-r (m1 m2)
 607   (let ((n1 (string-to-number (vm-su-line-count m1)))
 608         (n2 (string-to-number (vm-su-line-count m2))))
 609     (cond ((> n1 n2) t)
 610           ((= n1 n2) '=)
 611           (t nil))))
 612
 613 (defun vm-sort-compare-byte-count (m1 m2)
 614   (let ((n1 (string-to-number (vm-su-byte-count m1)))
 615         (n2 (string-to-number (vm-su-byte-count m2))))
 616     (cond ((< n1 n2) t)
 617           ((= n1 n2) '=)
 618           (t nil))))
 619
 620 (defun vm-sort-compare-byte-count-r (m1 m2)
 621   (let ((n1 (string-to-number (vm-su-byte-count m1)))
 622         (n2 (string-to-number (vm-su-byte-count m2))))
 623     (cond ((> n1 n2) t)
 624           ((= n1 n2) '=)
 625           (t nil))))
 626
 627 (defun vm-sort-compare-spam-score (m1 m2)
 628   (let ((s1 (vm-su-spam-score m1))
 629         (s2 (vm-su-spam-score m2)))
 630     (cond ((< s1 s2) t)
 631           ((= s1 s2) '=)
 632           (t nil))))
 633
 634 (defun vm-sort-compare-spam-score-r (m1 m2)
 635   (let ((s1 (vm-su-spam-score m1))
 636         (s2 (vm-su-spam-score m2)))
 637     (cond ((< s1 s2) nil)
 638           ((= s1 s2) '=)
 639           (t t))))
 640
 641 ;;;###autoload
 642 (defun vm-sort-compare-physical-order (m1 m2)
 643   (let ((n1 (vm-start-of m1))
 644         (n2 (vm-start-of m2)))
 645     (cond ((< n1 n2) t)
 646           ((= n1 n2) '=)
 647           (t nil))))
 648
 649 ;;;###autoload
 650 (defun vm-sort-compare-physical-order-r (m1 m2)
 651   (let ((n1 (vm-start-of m1))
 652         (n2 (vm-start-of m2)))
 653     (cond ((> n1 n2) t)
 654           ((= n1 n2) '=)
 655           (t nil))))
 656
 657 (add-to-list 'vm-supported-sort-keys "header")
 658
 659 (defun vm-get-headers-of (m &optional headers)
 660   (save-excursion
 661     (save-restriction
 662       (widen)
 663      (let ((end (vm-text-of m)))
 664        (set-buffer (vm-buffer-of m))
 665        (goto-char (vm-start-of m))
 666        (while (re-search-forward "^[^: \n\t]+:" end t)
 667          (add-to-list 'headers (match-string 0)))
 668        headers))))
 669
 670 (defun vm-sort-compare-header (m1 m2)
 671   (if (null vm-sort-compare-header)
 672       (setq vm-sort-compare-header
 673             (completing-read
 674              (if (car vm-sort-compare-header-history)
 675                  (format "Sort hy header (%s): "
 676                          (car vm-sort-compare-header-history))
 677                "Sort hy header: ")
 678              (mapcar (lambda (h) (list h))
 679                      (vm-get-headers-of m2 (vm-get-headers-of m1)))
 680              nil nil nil
 681              'vm-sort-compare-header-history
 682              (car vm-sort-compare-header-history)))
 683     (string< (vm-get-header-contents m1 vm-sort-compare-header)
 684              (vm-get-header-contents m2 vm-sort-compare-header))))
 685
 686 (provide 'vm-sort)
 687
 688 ;;; vm-sort.el ends here