+;;;
+;;; Intelli-mouse commmands
+;;;
+
+(defun gnus-wheel-summary-scroll (event)
+ (interactive "e")
+ (let ((amount (if (memq 'shift (event-modifiers event))
+ (car gnus-wheel-scroll-amount)
+ (cdr gnus-wheel-scroll-amount)))
+ (direction (- (* (static-if (featurep 'xemacs)
+ (event-button event)
+ (cond ((eq 'mouse-4 (event-basic-type event))
+ 4)
+ ((eq 'mouse-5 (event-basic-type event))
+ 5)))
+ 2) 9))
+ edge)
+ (gnus-summary-scroll-up (* amount direction))
+ (when (gnus-eval-in-buffer-window gnus-article-buffer
+ (save-restriction
+ (widen)
+ (and (if (< 0 direction)
+ (gnus-article-next-page 0)
+ (gnus-article-prev-page 0)
+ (bobp))
+ (if (setq edge (get-text-property
+ (point-min) 'gnus-wheel-edge))
+ (setq edge (* edge direction))
+ (setq edge -1))
+ (or (plusp edge)
+ (let ((buffer-read-only nil)
+ (inhibit-read-only t))
+ (put-text-property (point-min) (point-max)
+ 'gnus-wheel-edge direction)
+ nil))
+ (or (> edge gnus-wheel-edge-resistance)
+ (let ((buffer-read-only nil)
+ (inhibit-read-only t))
+ (put-text-property (point-min) (point-max)
+ 'gnus-wheel-edge
+ (* (1+ edge) direction))
+ nil))
+ (eq last-command 'gnus-wheel-summary-scroll))
+ ))
+ (gnus-summary-next-article nil nil (minusp direction)))
+ ))
+
+(defun gnus-wheel-install ()
+ "Enable mouse wheel support on summary window."
+ (when gnus-use-wheel
+ (let ((keys
+ '([(mouse-4)] [(shift mouse-4)] [(mouse-5)] [(shift mouse-5)])))
+ (dolist (key keys)
+ (define-key gnus-summary-mode-map key
+ 'gnus-wheel-summary-scroll)))))
+
+(add-hook 'gnus-summary-mode-hook 'gnus-wheel-install)
+
+;;;
+;;; with article
+;;;
+
+(defmacro gnus-with-article (article &rest forms)
+ "Select ARTICLE and perform FORMS in the original article buffer.
+Then replace the article with the result."
+ `(progn
+ ;; We don't want the article to be marked as read.
+ (let (gnus-mark-article-hook)
+ (gnus-summary-select-article t t nil ,article))
+ (set-buffer gnus-original-article-buffer)
+ ,@forms
+ (if (not (gnus-check-backend-function
+ 'request-replace-article (car gnus-article-current)))
+ (gnus-message 5 "Read-only group; not replacing")
+ (unless (gnus-request-replace-article
+ ,article (car gnus-article-current)
+ (current-buffer) t)
+ (error "Couldn't replace article")))
+ ;; The cache and backlog have to be flushed somewhat.
+ (when gnus-keep-backlog
+ (gnus-backlog-remove-article
+ (car gnus-article-current) (cdr gnus-article-current)))
+ (when gnus-use-cache
+ (gnus-cache-update-article
+ (car gnus-article-current) (cdr gnus-article-current)))))
+
+(put 'gnus-with-article 'lisp-indent-function 1)
+(put 'gnus-with-article 'edebug-form-spec '(form body))
+
+;;;
+;;; Generic summary marking commands
+;;;
+
+(defvar gnus-summary-marking-alist
+ '((read gnus-del-mark "d")
+ (unread gnus-unread-mark "u")
+ (ticked gnus-ticked-mark "!")
+ (dormant gnus-dormant-mark "?")
+ (expirable gnus-expirable-mark "e"))
+ "An alist of names/marks/keystrokes.")
+
+(defvar gnus-summary-generic-mark-map (make-sparse-keymap))
+(defvar gnus-summary-mark-map)
+
+(defun gnus-summary-make-all-marking-commands ()
+ (define-key gnus-summary-mark-map "M" gnus-summary-generic-mark-map)
+ (dolist (elem gnus-summary-marking-alist)
+ (apply 'gnus-summary-make-marking-command elem)))
+
+(defun gnus-summary-make-marking-command (name mark keystroke)
+ (let ((map (make-sparse-keymap)))
+ (define-key gnus-summary-generic-mark-map keystroke map)
+ (dolist (lway `((next "next" next nil "n")
+ (next-unread "next unread" next t "N")
+ (prev "previous" prev nil "p")
+ (prev-unread "previous unread" prev t "P")
+ (nomove "" nil nil ,keystroke)))
+ (let ((func (gnus-summary-make-marking-command-1
+ mark (car lway) lway name)))
+ (setq func (eval func))
+ (define-key map (nth 4 lway) func)))))
+
+(defun gnus-summary-make-marking-command-1 (mark way lway name)
+ `(defun ,(intern
+ (format "gnus-summary-put-mark-as-%s%s"
+ name (if (eq way 'nomove)
+ ""
+ (concat "-" (symbol-name way)))))
+ (n)
+ ,(format
+ "Mark the current article as %s%s.
+If N, the prefix, then repeat N times.
+If N is negative, move in reverse order.
+The difference between N and the actual number of articles marked is
+returned."
+ name (car (cdr lway)))
+ (interactive "p")
+ (gnus-summary-generic-mark n ,mark ',(nth 2 lway) ,(nth 3 lway))))
+
+(defun gnus-summary-generic-mark (n mark move unread)
+ "Mark N articles with MARK."
+ (unless (eq major-mode 'gnus-summary-mode)
+ (error "This command can only be used in the summary buffer"))
+ (gnus-summary-show-thread)
+ (let ((nummove
+ (cond
+ ((eq move 'next) 1)
+ ((eq move 'prev) -1)
+ (t 0))))
+ (if (zerop nummove)
+ (setq n 1)
+ (when (< n 0)
+ (setq n (abs n)
+ nummove (* -1 nummove))))
+ (while (and (> n 0)
+ (gnus-summary-mark-article nil mark)
+ (zerop (gnus-summary-next-subject nummove unread t)))
+ (setq n (1- n)))
+ (when (/= 0 n)
+ (gnus-message 7 "No more %sarticles" (if mark "" "unread ")))
+ (gnus-summary-recenter)
+ (gnus-summary-position-point)
+ (gnus-set-mode-line 'summary)
+ n))
+
+(gnus-summary-make-all-marking-commands)
+
projects / elisp / gnus.git- / blobdiff