Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-virtual.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents 131b0175ea99
children 4be1180a9e89
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;;; Virtual folders for VM 1 ;;; Virtual folders for VM
2 ;;; Copyright (C) 1990, 1993, 1994, 1995 Kyle E. Jones 2 ;;; Copyright (C) 1990-1997 Kyle E. Jones
3 ;;; 3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify 4 ;;; This program is free software; you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by 5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation; either version 1, or (at your option) 6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version. 7 ;;; any later version.
163 (save-excursion 163 (save-excursion
164 (set-buffer 164 (set-buffer
165 (vm-buffer-of 165 (vm-buffer-of
166 (vm-real-message-of 166 (vm-real-message-of
167 (car mp)))) 167 (car mp))))
168 (apply 'vm-vs-or (vm-real-message-of (car mp)) 168 (apply 'vm-vs-or (car mp) selectors))
169 selectors))
170 (apply 'vm-vs-or (car mp) selectors))) 169 (apply 'vm-vs-or (car mp) selectors)))
171 (progn 170 (progn
172 (intern 171 (intern
173 (vm-message-id-number-of 172 (vm-message-id-number-of
174 (vm-real-message-of (car mp))) 173 (vm-real-message-of (car mp)))
219 ;; real messages, virtual buffers to the real buffers, and no 218 ;; real messages, virtual buffers to the real buffers, and no
220 ;; message list has been installed. 219 ;; message list has been installed.
221 ;; 220 ;;
222 ;; Now we tie it all together, with this section of code being 221 ;; Now we tie it all together, with this section of code being
223 ;; uninterruptible. 222 ;; uninterruptible.
224 (let ((inhibit-quit t)) 223 (let ((inhibit-quit t)
224 (label-obarray vm-label-obarray))
225 (if (null vm-real-buffers) 225 (if (null vm-real-buffers)
226 (setq vm-real-buffers real-buffers-used)) 226 (setq vm-real-buffers real-buffers-used))
227 (save-excursion 227 (save-excursion
228 (while real-buffers-used 228 (while real-buffers-used
229 (set-buffer (car real-buffers-used)) 229 (set-buffer (car real-buffers-used))
230 ;; inherit the global label lists of all the associated
231 ;; real folders.
232 (mapatoms (function (lambda (x) (intern (symbol-name x)
233 label-obarray)))
234 vm-label-obarray)
230 (if (not (memq vbuffer vm-virtual-buffers)) 235 (if (not (memq vbuffer vm-virtual-buffers))
231 (setq vm-virtual-buffers (cons vbuffer vm-virtual-buffers))) 236 (setq vm-virtual-buffers (cons vbuffer vm-virtual-buffers)))
232 (setq real-buffers-used (cdr real-buffers-used)))) 237 (setq real-buffers-used (cdr real-buffers-used))))
233 (setq mp new-message-list) 238 (setq mp new-message-list)
234 (while mp 239 (while mp
350 (defun vm-virtual-help () 355 (defun vm-virtual-help ()
351 (interactive) 356 (interactive)
352 (vm-display nil nil '(vm-virtual-help) '(vm-virtual-help)) 357 (vm-display nil nil '(vm-virtual-help) '(vm-virtual-help))
353 (message "VV = visit, VA = apply selectors, VC = create, VM = toggle virtual mirror")) 358 (message "VV = visit, VA = apply selectors, VC = create, VM = toggle virtual mirror"))
354 359
355 (defun vm-delete-directory-file-names (list)
356 (vm-delete 'file-directory-p list))
357
358 (defun vm-delete-backup-file-names (list)
359 (vm-delete 'backup-file-name-p list))
360
361 (defun vm-delete-auto-save-file-names (list)
362 (vm-delete 'auto-save-file-name-p list))
363
364 (defun vm-vs-or (m &rest selectors) 360 (defun vm-vs-or (m &rest selectors)
365 (let ((result nil) selector arglist) 361 (let ((result nil) selector arglist)
366 (while selectors 362 (while selectors
367 (setq selector (car (car selectors)) 363 (setq selector (car (car selectors))
368 arglist (cdr (car selectors)) 364 arglist (cdr (car selectors))
405 401
406 (defun vm-vs-header (m arg) 402 (defun vm-vs-header (m arg)
407 (save-excursion 403 (save-excursion
408 (save-restriction 404 (save-restriction
409 (widen) 405 (widen)
410 (goto-char (vm-headers-of m)) 406 (goto-char (vm-headers-of (vm-real-message-of m)))
411 (re-search-forward arg (vm-text-of m) t)))) 407 (re-search-forward arg (vm-text-of (vm-real-message-of m)) t))))
412 408
413 (defun vm-vs-label (m arg) 409 (defun vm-vs-label (m arg)
414 (vm-member arg (vm-labels-of m))) 410 (vm-member arg (vm-labels-of m)))
415 411
416 (defun vm-vs-text (m arg) 412 (defun vm-vs-text (m arg)
417 (save-excursion 413 (save-excursion
418 (save-restriction 414 (save-restriction
419 (widen) 415 (widen)
420 (goto-char (vm-text-of m)) 416 (goto-char (vm-text-of (vm-real-message-of m)))
421 (re-search-forward arg (vm-text-end-of m) t)))) 417 (re-search-forward arg (vm-text-end-of (vm-real-message-of m)) t))))
422 418
423 (defun vm-vs-more-chars-than (m arg) 419 (defun vm-vs-more-chars-than (m arg)
424 (> (string-to-int (vm-su-byte-count m)) arg)) 420 (> (string-to-int (vm-su-byte-count m)) arg))
425 421
426 (defun vm-vs-less-chars-than (m arg) 422 (defun vm-vs-less-chars-than (m arg)
483 prompt 479 prompt
484 (vm-obarray-to-string-list 480 (vm-obarray-to-string-list
485 vm-label-obarray) 481 vm-label-obarray)
486 nil))))) 482 nil)))))
487 (t (setq arg (read-string prompt)))))) 483 (t (setq arg (read-string prompt))))))
484 (or (fboundp (intern (concat "vm-vs-" (symbol-name selector))))
485 (error "Invalid selector"))
488 (list selector arg))) 486 (list selector arg)))
489 487
490 ;; clear away links between real and virtual folders when 488 ;; clear away links between real and virtual folders when
491 ;; a vm-quit is performed in either type folder. 489 ;; a vm-quit is performed in either type folder.
492 (defun vm-virtual-quit () 490 (defun vm-virtual-quit ()
534 (while bp 532 (while bp
535 (set-buffer (car bp)) 533 (set-buffer (car bp))
536 (setq vm-real-buffers (delq b vm-real-buffers)) 534 (setq vm-real-buffers (delq b vm-real-buffers))
537 ;; set the message pointer to a new value if it is 535 ;; set the message pointer to a new value if it is
538 ;; now invalid. 536 ;; now invalid.
539 (setq vmp vm-message-pointer) 537 (cond
540 (while (and vm-message-pointer 538 ((equal "Q" (vm-message-id-number-of (car vm-message-pointer)))
541 (equal "Q" (vm-message-id-number-of 539 (vm-garbage-collect-message)
542 (car vm-message-pointer)))) 540 (setq vmp vm-message-pointer)
543 (setq vm-message-pointer 541 (while (and vm-message-pointer
544 (cdr vm-message-pointer))) 542 (equal "Q" (vm-message-id-number-of
545 ;; if there were no good messages ahead, try going 543 (car vm-message-pointer))))
546 ;; backward. 544 (setq vm-message-pointer
547 (if (null vm-message-pointer) 545 (cdr vm-message-pointer)))
548 (progn 546 ;; if there were no good messages ahead, try going
549 (setq vm-message-pointer vmp) 547 ;; backward.
550 (while (and vm-message-pointer 548 (if (null vm-message-pointer)
551 (equal "Q" (vm-message-id-number-of 549 (progn
552 (car vm-message-pointer)))) 550 (setq vm-message-pointer vmp)
553 (setq vm-message-pointer 551 (while (and vm-message-pointer
554 (vm-reverse-link-of (car vm-message-pointer)))))) 552 (equal "Q" (vm-message-id-number-of
553 (car vm-message-pointer))))
554 (setq vm-message-pointer
555 (vm-reverse-link-of
556 (car vm-message-pointer))))))))
555 ;; expunge the virtual messages associated with 557 ;; expunge the virtual messages associated with
556 ;; real messages that are going away. 558 ;; real messages that are going away.
557 (setq vm-message-list 559 (setq vm-message-list
558 (vm-delete (function 560 (vm-delete (function
559 (lambda (m) 561 (lambda (m)