;;; Sorting and moving messages inside VM;;; Copyright (C) 1993, 1994 Kyle E. Jones;;;;;; This program is free software; you can redistribute it and/or modify;;; it under the terms of the GNU General Public License as published by;;; the Free Software Foundation; either version 1, or (at your option);;; any later version.;;;;;; This program is distributed in the hope that it will be useful,;;; but WITHOUT ANY WARRANTY; without even the implied warranty of;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the;;; GNU General Public License for more details.;;;;;; You should have received a copy of the GNU General Public License;;; along with this program; if not, write to the Free Software;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.(provide'vm-sort)(defunvm-move-message-forward(count)"Move a message forward in a VM folder.Prefix arg COUNT causes the current message to be moved COUNT messages forward.A negative COUNT causes movement to be backward instead of forward.COUNT defaults to 1. The current message remains selected after beingmoved.If vm-move-messages-physically is non-nil, the physical copy ofthe message in the folder is moved. A nil value means justchange the presentation order and leave the physical order ofthe folder undisturbed."(interactive"p")(vm-follow-summary-cursor)(vm-select-folder-buffer)(vm-check-for-killed-summary)(vm-error-if-folder-empty)(ifvm-move-messages-physically(vm-error-if-folder-read-only))(vm-displaynilnil'(vm-move-message-forwardvm-move-message-backwardvm-move-message-forward-physicallyvm-move-message-backward-physically)(listthis-command))(let*((ovmpvm-message-pointer)vmp-prevovmp-prev(vm-message-pointervm-message-pointer)(direction(if(>count0)'forward'backward))(count(vm-abscount)))(while(not(zeropcount))(vm-move-message-pointerdirection)(vm-decrementcount))(if(>(string-to-int(vm-number-of(carvm-message-pointer)))(string-to-int(vm-number-of(carovmp))))(setqvm-message-pointer(cdrvm-message-pointer)))(if(eqvm-message-pointerovmp)()(if(nullvm-message-pointer)(setqvmp-prev(vm-lastvm-message-list))(setqvmp-prev(vm-reverse-link-of(carvm-message-pointer))))(setqovmp-prev(vm-reverse-link-of(carovmp)));; lock out interrupts to preserve message list integrity.(let((inhibit-quitt))(ifovmp-prev(progn(setcdrovmp-prev(cdrovmp))(and(cdrovmp)(vm-set-reverse-link-of(car(cdrovmp))ovmp-prev)))(setqvm-message-list(cdrovmp))(vm-set-reverse-link-of(carvm-message-list)nil))(ifvmp-prev(progn(setcdrvmp-prevovmp)(vm-set-reverse-link-of(carovmp)vmp-prev))(setqvm-message-listovmp)(vm-set-reverse-link-of(carvm-message-list)nil))(setcdrovmpvm-message-pointer)(andvm-message-pointer(vm-set-reverse-link-of(carvm-message-pointer)ovmp))(if(andvm-move-messages-physically(not(eqmajor-mode'vm-virtual-mode)))(vm-physically-move-message(carovmp)(carvm-message-pointer)))(setqvm-ml-sort-keysnil)(if(notvm-folder-read-only)(progn(setqvm-message-order-changedt)(vm-set-buffer-modified-pt)(vm-clear-modification-flag-undos))))(cond((nullovmp-prev)(setqvm-numbering-redo-start-pointvm-message-listvm-numbering-redo-end-pointvm-message-pointervm-summary-pointer(carvm-message-list)))((nullvmp-prev)(setqvm-numbering-redo-start-pointvm-message-listvm-numbering-redo-end-point(cdrovmp-prev)vm-summary-pointer(carovmp-prev)))((or(notvm-message-pointer)(<(string-to-int(vm-number-of(carovmp-prev)))(string-to-int(vm-number-of(carvm-message-pointer)))))(setqvm-numbering-redo-start-point(cdrovmp-prev)vm-numbering-redo-end-point(cdrovmp)vm-summary-pointer(car(cdrovmp-prev))))(t(setqvm-numbering-redo-start-pointovmpvm-numbering-redo-end-point(cdrovmp-prev)vm-summary-pointer(carovmp-prev))))(ifvm-summary-buffer(let(listmp)(vm-copy-local-variablesvm-summary-buffer'vm-summary-pointer)(setqvm-need-summary-pointer-updatet)(setqmpvm-numbering-redo-start-point)(while(not(eqmpvm-numbering-redo-end-point))(vm-mark-for-summary-update(carmp))(setqlist(cons(carmp)list)mp(cdrmp)))(vm-mapc(function(lambda(mp)(vm-set-su-start-ofm(carp))(vm-set-su-end-ofm(car(cdrp)))))(setqlist(nreverselist))(sort(mapcar(function(lambda(p)(list(vm-su-start-ofp)(vm-su-end-ofp))))list)(function(lambda(pq)(<(carp)(carq))))))))))(ifvm-move-messages-physically;; clip region is messed up(vm-preview-current-message)(vm-update-summary-and-mode-line)))(defunvm-move-message-backward(count)"Move a message backward in a VM folder.Prefix arg COUNT causes the current message to be moved COUNTmessages backward. A negative COUNT causes movement to beforward instead of backward. COUNT defaults to 1. The currentmessage remains selected after being moved.If vm-move-messages-physically is non-nil, the physical copy ofthe message in the folder is moved. A nil value means justchange the presentation order and leave the physical order ofthe folder undisturbed."(interactive"p")(vm-move-message-forward(-count)))(defunvm-move-message-forward-physically(count)"Like vm-move-message-forward but always move the message physically."(interactive"p")(let((vm-move-messages-physicallyt))(vm-move-message-forwardcount)))(defunvm-move-message-backward-physically(count)"Like vm-move-message-backward but always move the message physically."(interactive"p")(let((vm-move-messages-physicallyt))(vm-move-message-backwardcount)));; move message m to be before m-dest;; and fix up the location markers afterwards.;; m better not equal m-dest.;; of m-dest is nil, move m to the end of buffer.;;;; consider carefully the effects of insertion on markers;; and variables containg markers before you modify this code.(defunvm-physically-move-message(mm-dest)(save-excursion(vm-save-restriction(widen);; Make sure vm-headers-of and vm-text-of are non-nil in;; their slots before we try to move them. (Simply;; referencing the slot with their slot function is;; sufficient to guarantee this.) Otherwise, they be;; initialized in the middle of the message move and get the;; offset applied to them twice by way of a relative offset;; from one of the other location markers that has already;; been moved.;;;; Also, and more importantly, vm-vheaders-of might run;; vm-reorder-message-headers, which can add text to;; message. This MUST NOT happen after offsets have been;; computed for the message move or varying levels of chaos;; will ensue. In the case of BABYL files, where;; vm-reorder-message-headers can add a lot of new text,;; folder curroption can be massive.(vm-text-ofm)(vm-vheaders-ofm)(let((dest-start(ifm-dest(vm-start-ofm-dest)(point-max)))(buffer-read-onlynil)offsetdoomed-startdoomed-end)(goto-chardest-start)(insert-buffer-substring(current-buffer)(vm-start-ofm)(vm-end-ofm))(setqdoomed-start(marker-position(vm-start-ofm))doomed-end(marker-position(vm-end-ofm))offset(-(vm-start-ofm)dest-start))(set-marker(vm-start-ofm)(-(vm-start-ofm)offset))(set-marker(vm-headers-ofm)(-(vm-headers-ofm)offset))(set-marker(vm-text-end-ofm)(-(vm-text-end-ofm)offset))(set-marker(vm-end-ofm)(-(vm-end-ofm)offset))(set-marker(vm-text-ofm)(-(vm-text-ofm)offset))(set-marker(vm-vheaders-ofm)(-(vm-vheaders-ofm)offset));; now fix the start of m-dest since it didn't;; move forward with its message.(andm-dest(set-marker(vm-start-ofm-dest)(vm-end-ofm)));; delete the old copy of the message(delete-regiondoomed-startdoomed-end)))))(defunvm-so-sortable-datestring(m)(or(vm-sortable-datestring-ofm)(progn(vm-set-sortable-datestring-ofm(condition-casenil(vm-timezone-make-date-sortable(or(vm-get-header-contentsm"Date:")(vm-grok-From_-datem)"Thu, 1 Jan 1970 00:00:00 GMT"))(x-error"1970010100:00:00")))(vm-sortable-datestring-ofm))))(defunvm-so-sortable-subject(m)(or(vm-sortable-subject-ofm)(progn(vm-set-sortable-subject-ofm(let((case-fold-searcht)(subject(vm-su-subjectm)))(if(andvm-subject-ignored-prefix(string-matchvm-subject-ignored-prefixsubject)(zerop(match-beginning0)))(setqsubject(substringsubject(match-end0))))(if(andvm-subject-ignored-suffix(string-matchvm-subject-ignored-suffixsubject)(=(match-end0)(lengthsubject)))(setqsubject(substringsubject0(match-beginning0))))(setqsubject(vm-with-string-as-temp-buffersubject(functionvm-collapse-whitespace)))(if(andvm-subject-significant-chars(natnumpvm-subject-significant-chars)(<vm-subject-significant-chars(lengthsubject)))(setqsubject(substringsubject0vm-subject-significant-chars)))subject))(vm-sortable-subject-ofm))))(defunvm-sort-messages(keys&optionallets-get-physical)"Sort message in a folder by the specified KEYS.You may sort by more than one particular message key. Ifmessages compare equal by the first key, the second key will becompared and so on. When called interactively the keys will beread from the minibuffer. Valid keys are\"date\" \"reversed-date\"\"author\" \"reversed-author\"\"subject\" \"reversed-subject\"\"recipients\" \"reversed-recipients\"\"line-count\" \"reversed-line-count\"\"byte-count\" \"reversed-byte-count\"\"physical-order\" \"reversed-physical-order\"Optional second arg (prefix arg interactively) means the sortshould change the physical order of the messages in the folder.Normally VM changes presentation order only, leaving thefolder in the order in which the messages arrived."(interactive(let((last-commandlast-command)(this-commandthis-command))(list(vm-read-string(if(orcurrent-prefix-argvm-move-messages-physically)"Physically sort messages by: ""Sort messages by: ")vm-supported-sort-keyst)current-prefix-arg)))(vm-select-folder-buffer)(vm-check-for-killed-summary);; only squawk if interactive. The thread display uses this;; function and doesn't expect errors.(if(interactive-p)(vm-error-if-folder-empty));; ditto(if(and(interactive-p)(orvm-move-messages-physicallylets-get-physical))(vm-error-if-folder-read-only))(vm-displaynilnil'(vm-sort-messages)'(vm-sort-messages))(let(key-listkey-funcskeyml-keysphysical-order-listold-message-listnew-message-listmp-oldmp-newold-startdoomed-startdoomed-endoffset(order-did-changenil)virtualphysical)(setqkey-list(vm-parsekeys"[ \t]*\\([^ \t]+\\)")ml-keys(andkey-list(mapconcat(functionidentity)key-list"/"))key-funcsnilold-message-listvm-message-listvirtual(eqmajor-mode'vm-virtual-mode)physical(and(orlets-get-physicalvm-move-messages-physically)(notvm-folder-read-only)(notvirtual)))(orkey-list(error"No sort keys specified."))(whilekey-list(setqkey(carkey-list))(cond((equalkey"thread")(vm-build-threads-if-unbuilt)(vm-build-thread-lists)(setqkey-funcs(cons'vm-sort-compare-threadkey-funcs)))((equalkey"author")(setqkey-funcs(cons'vm-sort-compare-authorkey-funcs)))((equalkey"reversed-author")(setqkey-funcs(cons'vm-sort-compare-author-rkey-funcs)))((equalkey"date")(setqkey-funcs(cons'vm-sort-compare-datekey-funcs)))((equalkey"reversed-date")(setqkey-funcs(cons'vm-sort-compare-date-rkey-funcs)))((equalkey"subject")(setqkey-funcs(cons'vm-sort-compare-subjectkey-funcs)))((equalkey"reversed-subject")(setqkey-funcs(cons'vm-sort-compare-subject-rkey-funcs)))((equalkey"recipients")(setqkey-funcs(cons'vm-sort-compare-recipientskey-funcs)))((equalkey"reversed-recipients")(setqkey-funcs(cons'vm-sort-compare-recipients-rkey-funcs)))((equalkey"byte-count")(setqkey-funcs(cons'vm-sort-compare-byte-countkey-funcs)))((equalkey"reversed-byte-count")(setqkey-funcs(cons'vm-sort-compare-byte-count-rkey-funcs)))((equalkey"line-count")(setqkey-funcs(cons'vm-sort-compare-line-countkey-funcs)))((equalkey"reversed-line-count")(setqkey-funcs(cons'vm-sort-compare-line-count-rkey-funcs)))((equalkey"physical-order")(setqkey-funcs(cons'vm-sort-compare-physical-orderkey-funcs)))((equalkey"reversed-physical-order")(setqkey-funcs(cons'vm-sort-compare-physical-order-rkey-funcs)))(t(error"Unknown key: %s"key)))(setqkey-list(cdrkey-list)));; if this is not a thread sort and threading is enabled,;; then disable threading and make sure the whole summary is;; regenerated (to recalculate %I everywhere).(if(andvm-summary-show-threads(not(equalkey-funcs'(vm-sort-compare-thread))))(progn(setqvm-summary-show-threadsnil)(vm-set-summary-redo-start-pointt)))(message"Sorting...")(let((vm-key-functions(nreversekey-funcs)))(setqnew-message-list(sort(copy-sequenceold-message-list)'vm-sort-compare-xxxxxx));; only need to do this sort if we're going to physically;; move messages later.(ifphysical(setqvm-key-functions'(vm-sort-compare-physical-order)physical-order-list(sort(copy-sequenceold-message-list)'vm-sort-compare-xxxxxx))))(message"Sorting... done")(let((inhibit-quitt))(setqmp-oldold-message-listmp-newnew-message-list)(whilemp-new(if(eq(carmp-old)(carmp-new))(setqmp-old(cdrmp-old)mp-new(cdrmp-new))(setqorder-did-changet);; unless a full redo has been requested, the numbering;; start point now points to a cons in the old message;; list. therefore we just change the variable;; directly to avoid the list scan that;; vm-set-numbering-redo-start-point does.(cond((not(eqvm-numbering-redo-start-pointt))(setqvm-numbering-redo-start-pointmp-newvm-numbering-redo-end-pointnil)))(ifvm-summary-buffer(progn(setqvm-need-summary-pointer-updatet);; same logic as numbering reset above...(cond((not(eqvm-summary-redo-start-pointt))(setqvm-summary-redo-start-pointmp-new)));; start point of this message's summary is now;; wrong relative to where it is in the;; message list. fix it and the summary rebuild;; will take care of the rest.(vm-set-su-start-of(carmp-new)(vm-su-start-of(carmp-old)))))(setqmp-newnil)))(if(andorder-did-changephysical)(let((buffer-read-onlynil));; the folder is being physically ordered so we don't;; need a message order header to be stuffed, nor do;; we need to retain one in the folder buffer. so we;; strip out any existing message order header and;; say there are no changes to prevent a message;; order header from being stuffed later.(vm-remove-message-order)(setqvm-message-order-changednil)(message"Moving messages... ")(widen)(setqmp-oldphysical-order-listmp-newnew-message-list)(setqold-start(vm-start-of(carmp-old)))(whilemp-new(if(<(vm-start-of(carmp-old))old-start);; already moved this message(setqmp-old(cdrmp-old))(if(eq(carmp-old)(carmp-new))(setqmp-old(cdrmp-old)mp-new(cdrmp-new));; move message(vm-physically-move-message(carmp-new)(carmp-old));; record start position. if vm-start-of;; mp-old ever becomes less than old-start;; we're running into messages that have;; already been moved.(setqold-start(vm-start-of(carmp-old)));; move mp-new but not mp-old because we moved;; mp-old down one message by inserting a;; message in front of it.(setqmp-new(cdrmp-new)))))(message"Moving messages... done")(vm-set-buffer-modified-pt)(vm-clear-modification-flag-undos))(if(andorder-did-change(notvm-folder-read-only))(progn(setqvm-message-order-changedt)(vm-set-buffer-modified-pt)(vm-clear-modification-flag-undos))))(setqvm-ml-sort-keysml-keys)(intern(buffer-name)vm-buffers-needing-display-update)(cond(order-did-change(setqvm-message-listnew-message-list)(vm-reverse-link-messages)(ifvm-message-pointer(setqvm-message-pointer(or(cdr(vm-reverse-link-of(carvm-message-pointer)))vm-message-list)))(ifvm-last-message-pointer(setqvm-last-message-pointer(or(cdr(vm-reverse-link-of(carvm-last-message-pointer)))vm-message-list))))))(if(andvm-message-pointerorder-did-change(orlets-get-physicalvm-move-messages-physically));; clip region is most likely messed up(vm-preview-current-message)(vm-update-summary-and-mode-line))))(defunvm-sort-compare-xxxxxx(m1m2)(let((key-funcsvm-key-functions)result)(while(andkey-funcs(eq'=(setqresult(funcall(carkey-funcs)m1m2))))(setqkey-funcs(cdrkey-funcs)))(andkey-funcsresult)))(defunvm-sort-compare-thread(m1m2)(let((list1(vm-th-thread-listm1))(list2(vm-th-thread-listm2)))(catch'done(if(not(eq(carlist1)(carlist2)))(let((date1(get(carlist1)'oldest-date))(date2(get(carlist2)'oldest-date)))(cond((string-lesspdate1date2)t)((string-equaldate1date2)(string-lessp(carlist1)(carlist2)))(tnil)))(while(andlist1list2)(cond((string-lessp(carlist1)(carlist2))(throw'donet))((not(string-equal(carlist1)(carlist2)))(throw'donenil)))(setqlist1(cdrlist1)list2(cdrlist2)))(cond((andlist1(notlist2))nil)((andlist2(notlist1))t)(t'=))))))(defunvm-sort-compare-author(m1m2)(let((s1(vm-su-fromm1))(s2(vm-su-fromm2)))(cond((string-lessps1s2)t)((string-equals1s2)'=)(tnil))))(defunvm-sort-compare-author-r(m1m2)(let((s1(vm-su-fromm1))(s2(vm-su-fromm2)))(cond((string-lessps1s2)nil)((string-equals1s2)'=)(tt))))(defunvm-sort-compare-date(m1m2)(let((s1(vm-so-sortable-datestringm1))(s2(vm-so-sortable-datestringm2)))(cond((string-lessps1s2)t)((string-equals1s2)'=)(tnil))))(defunvm-sort-compare-date-r(m1m2)(let((s1(vm-so-sortable-datestringm1))(s2(vm-so-sortable-datestringm2)))(cond((string-lessps1s2)nil)((string-equals1s2)'=)(tt))))(defunvm-sort-compare-recipients(m1m2)(let((s1(vm-su-tom1))(s2(vm-su-tom2)))(cond((string-lessps1s2)t)((string-equals1s2)'=)(tnil))))(defunvm-sort-compare-recipients-r(m1m2)(let((s1(vm-su-tom1))(s2(vm-su-tom2)))(cond((string-lessps1s2)nil)((string-equals1s2)'=)(tt))))(defunvm-sort-compare-subject(m1m2)(let((s1(vm-so-sortable-subjectm1))(s2(vm-so-sortable-subjectm2)))(cond((string-lessps1s2)t)((string-equals1s2)'=)(tnil))))(defunvm-sort-compare-subject-r(m1m2)(let((s1(vm-so-sortable-subjectm1))(s2(vm-so-sortable-subjectm2)))(cond((string-lessps1s2)nil)((string-equals1s2)'=)(tt))))(defunvm-sort-compare-line-count(m1m2)(let((n1(string-to-int(vm-su-line-countm1)))(n2(string-to-int(vm-su-line-countm2))))(cond((<n1n2)t)((=n1n2)'=)(tnil))))(defunvm-sort-compare-line-count-r(m1m2)(let((n1(string-to-int(vm-su-line-countm1)))(n2(string-to-int(vm-su-line-countm2))))(cond((>n1n2)t)((=n1n2)'=)(tnil))))(defunvm-sort-compare-byte-count(m1m2)(let((n1(string-to-int(vm-su-byte-countm1)))(n2(string-to-int(vm-su-byte-countm2))))(cond((<n1n2)t)((=n1n2)'=)(tnil))))(defunvm-sort-compare-byte-count-r(m1m2)(let((n1(string-to-int(vm-su-byte-countm1)))(n2(string-to-int(vm-su-byte-countm2))))(cond((>n1n2)t)((=n1n2)'=)(tnil))))(defunvm-sort-compare-physical-order(m1m2)(let((n1(vm-start-ofm1))(n2(vm-start-ofm2)))(cond((<n1n2)t)((=n1n2)'=)(tnil))))(defunvm-sort-compare-physical-order-r(m1m2)(let((n1(vm-start-ofm1))(n2(vm-start-ofm2)))(cond((>n1n2)t)((=n1n2)'=)(tnil))))