xemacs-beta: lisp/gnus/gnus-salt.el comparison

comparison lisp/gnus/gnus-salt.el @ 16:0293115a14e9 r19-15b91

Import from CVS: tag r19-15b91

author	cvs
date	Mon, 13 Aug 2007 08:49:20 +0200
parents	376386a54a3c
children	d95e72db5c07

comparison

equal deleted inserted replaced

-:ad457d5f7d04
+:0293115a14e9
 ;;; gnus-salt.el --- alternate summary mode interfaces for Gnus
-;; Copyright (C) 1996 Free Software Foundation, Inc.
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
 ;; This file is part of GNU Emacs.
 ;;; Commentary:
 ;;; Code:
 (require 'gnus)
-(eval-when-compile (require 'cl))
+(require 'gnus-sum)
 ;;;
 ;;; gnus-pick-mode
 ;;;
 (defvar gnus-pick-display-summary nil
 "*Display summary while reading.")
 (defvar gnus-pick-mode-hook nil
 "Hook run in summary pick mode buffers.")
+(defvar gnus-mark-unpicked-articles-as-read nil
+"*If non-nil, mark all unpicked articles as read.")
+(defvar gnus-pick-elegant-flow t
+"If non-nil, gnus-pick-start-reading will run gnus-summary-next-group when no articles have been picked.")
+(defvar gnus-summary-pick-line-format
+"%-5P %U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n"
+"*The format specification of the lines in pick buffers.
+It accepts the same format specs that `gnus-summary-line-format' does.")
 ;;; Internal variables.
 (defvar gnus-pick-mode-map nil)
 (gnus-define-keys
 gnus-pick-mode-map
 "t" gnus-uu-mark-thread
 "T" gnus-uu-unmark-thread
-" " gnus-summary-mark-as-processable
+" " gnus-pick-next-page
 "u" gnus-summary-unmark-as-processable
 "U" gnus-summary-unmark-all-processable
 "v" gnus-uu-mark-over
 "r" gnus-uu-mark-region
 "R" gnus-uu-unmark-region
 "e" gnus-uu-mark-by-regexp
 "E" gnus-uu-mark-by-regexp
 "b" gnus-uu-mark-buffer
 "B" gnus-uu-unmark-buffer
+"." gnus-pick-article
+gnus-down-mouse-2 gnus-pick-mouse-pick-region
+;;gnus-mouse-2 gnus-pick-mouse-pick
+"X" gnus-pick-start-reading
 "\r" gnus-pick-start-reading))
 (defun gnus-pick-make-menu-bar ()
 (unless (boundp 'gnus-pick-menu)
 (easy-menu-define
 "Minor mode for providing a pick-and-read interface in Gnus summary buffers.
 \\{gnus-pick-mode-map}"
 (interactive "P")
 (when (eq major-mode 'gnus-summary-mode)
-(make-local-variable 'gnus-pick-mode)
+(if (not (set (make-local-variable 'gnus-pick-mode)
-(setq gnus-pick-mode
+		  (if (null arg) (not gnus-pick-mode)
-	  (if (null arg) (not gnus-pick-mode)
+		    (> (prefix-numeric-value arg) 0))))
-	    (> (prefix-numeric-value arg) 0)))
+	(remove-hook 'gnus-message-setup-hook 'gnus-pick-setup-message)
-(when gnus-pick-mode
 ;; Make sure that we don't select any articles upon group entry.
-(make-local-variable 'gnus-auto-select-first)
+(set (make-local-variable 'gnus-auto-select-first) nil)
-(setq gnus-auto-select-first nil)
+;; Change line format.
+(setq gnus-summary-line-format gnus-summary-pick-line-format)
+(setq gnus-summary-line-format-spec nil)
+(gnus-update-format-specifications nil 'summary)
+(gnus-update-summary-mark-positions)
+(add-hook 'gnus-message-setup-hook 'gnus-pick-setup-message)
+(set (make-local-variable 'gnus-summary-goto-unread) 'never)
 ;; Set up the menu.
-(when (and menu-bar-mode
+(when (gnus-visual-p 'pick-menu 'menu)
-		 (gnus-visual-p 'pick-menu 'menu))
 	(gnus-pick-make-menu-bar))
 (unless (assq 'gnus-pick-mode minor-mode-alist)
 	(push '(gnus-pick-mode " Pick") minor-mode-alist))
 (unless (assq 'gnus-pick-mode minor-mode-map-alist)
 	(push (cons 'gnus-pick-mode gnus-pick-mode-map)
 	      minor-mode-map-alist))
 (run-hooks 'gnus-pick-mode-hook))))
+(defun gnus-pick-setup-message ()
+"Make Message do the right thing on exit."
+(when (and (gnus-buffer-live-p gnus-summary-buffer)
+	     (save-excursion
+	       (set-buffer gnus-summary-buffer)
+	       gnus-pick-mode))
+(message-add-action
+'(gnus-configure-windows 'pick t) 'send 'exit 'postpone 'kill)))
+(defvar gnus-pick-line-number 1)
+(defun gnus-pick-line-number ()
+"Return the current line number."
+(if (bobp)
+(setq gnus-pick-line-number 1)
+(incf gnus-pick-line-number)))
 (defun gnus-pick-start-reading (&optional catch-up)
 "Start reading the picked articles.
 If given a prefix, mark all unpicked articles as read."
 (interactive "P")
-(unless gnus-newsgroup-processable
+(if gnus-newsgroup-processable
-(error "No articles have been picked"))
+(progn
 (gnus-summary-limit-to-articles nil)
-(when catch-up
+(when (or catch-up gnus-mark-unpicked-articles-as-read)
-(gnus-summary-limit-mark-excluded-as-read))
+	  (gnus-summary-limit-mark-excluded-as-read))
-(gnus-summary-first-unread-article)
+(gnus-summary-first-article)
-(gnus-configure-windows (if gnus-pick-display-summary 'article 'pick) t))
+(gnus-configure-windows
+	 (if gnus-pick-display-summary 'article 'pick) t))
+(if gnus-pick-elegant-flow
+	(progn
+	  (when (or catch-up gnus-mark-unpicked-articles-as-read)
+	    (gnus-summary-limit-mark-excluded-as-read))
+	  (if (gnus-group-quit-config gnus-newsgroup-name)
+	      (gnus-summary-exit)
+	    (gnus-summary-next-group)))
+(error "No articles have been picked"))))
+(defun gnus-pick-article (&optional arg)
+"Pick the article on the current line.
+If ARG, pick the article on that line instead."
+(interactive "P")
+(when arg
+(let (pos)
+(save-excursion
+	(goto-char (point-min))
+	(when (zerop (forward-line (1- (prefix-numeric-value arg))))
+	  (setq pos (point))))
+(if (not pos)
+	  (gnus-error 2 "No such line: %s" arg)
+	(goto-char pos))))
+(gnus-summary-mark-as-processable 1))
+(defun gnus-pick-mouse-pick (e)
+(interactive "e")
+(mouse-set-point e)
+(save-excursion
+(gnus-summary-mark-as-processable 1)))
+(defun gnus-pick-mouse-pick-region (start-event)
+"Pick articles that the mouse is dragged over.
+This must be bound to a button-down mouse event."
+(interactive "e")
+(mouse-minibuffer-check start-event)
+(let* ((echo-keystrokes 0)
+	 (start-posn (event-start start-event))
+	 (start-point (posn-point start-posn))
+(start-line (1+ (count-lines 1 start-point)))
+	 (start-window (posn-window start-posn))
+	 (start-frame (window-frame start-window))
+	 (bounds (window-edges start-window))
+	 (top (nth 1 bounds))
+	 (bottom (if (window-minibuffer-p start-window)
+		     (nth 3 bounds)
+		   ;; Don't count the mode line.
+		   (1- (nth 3 bounds))))
+	 (click-count (1- (event-click-count start-event))))
+(setq mouse-selection-click-count click-count)
+(setq mouse-selection-click-count-buffer (current-buffer))
+(mouse-set-point start-event)
+;; In case the down click is in the middle of some intangible text,
+;; use the end of that text, and put it in START-POINT.
+(when (< (point) start-point)
+(goto-char start-point))
+(gnus-pick-article)
+(setq start-point (point))
+;; end-of-range is used only in the single-click case.
+;; It is the place where the drag has reached so far
+;; (but not outside the window where the drag started).
+(let (event end end-point last-end-point (end-of-range (point)))
+(track-mouse
+(while (progn
+		(setq event (read-event))
+		(or (mouse-movement-p event)
+		    (eq (car-safe event) 'switch-frame)))
+	 (if (eq (car-safe event) 'switch-frame)
+	     nil
+	   (setq end (event-end event)
+		 end-point (posn-point end))
+	   (when end-point
+	     (setq last-end-point end-point))
+	   (cond
+	    ;; Are we moving within the original window?
+	    ((and (eq (posn-window end) start-window)
+		  (integer-or-marker-p end-point))
+	     ;; Go to START-POINT first, so that when we move to END-POINT,
+	     ;; if it's in the middle of intangible text,
+	     ;; point jumps in the direction away from START-POINT.
+	     (goto-char start-point)
+	     (goto-char end-point)
+	     (gnus-pick-article)
+	     ;; In case the user moved his mouse really fast, pick
+	     ;; articles on the line between this one and the last one.
+	     (let* ((this-line (1+ (count-lines 1 end-point)))
+		    (min-line (min this-line start-line))
+		    (max-line (max this-line start-line)))
+	       (while (< min-line max-line)
+		 (goto-line min-line)
+		 (gnus-pick-article)
+		 (setq min-line (1+ min-line)))
+	       (setq start-line this-line))
+	     (when (zerop (% click-count 3))
+	       (setq end-of-range (point))))
+	    (t
+	     (let ((mouse-row (cdr (cdr (mouse-position)))))
+	       (cond
+		((null mouse-row))
+		((< mouse-row top)
+		 (mouse-scroll-subr start-window (- mouse-row top)))
+		((>= mouse-row bottom)
+		 (mouse-scroll-subr start-window
+				    (1+ (- mouse-row bottom)))))))))))
+(when (consp event)
+	(let ((fun (key-binding (vector (car event)))))
+	  ;; Run the binding of the terminating up-event, if possible.
+	  ;; In the case of a multiple click, it gives the wrong results,
+	  ;; because it would fail to set up a region.
+	  (when nil
+	    ;; (and (= (mod mouse-selection-click-count 3) 0) (fboundp fun))
+	    ;; In this case, we can just let the up-event execute normally.
+	    (let ((end (event-end event)))
+	      ;; Set the position in the event before we replay it,
+	      ;; because otherwise it may have a position in the wrong
+	      ;; buffer.
+	      (setcar (cdr end) end-of-range)
+	      ;; Delete the overlay before calling the function,
+	      ;; because delete-overlay increases buffer-modified-tick.
+	      (push event unread-command-events))))))))
+(defun gnus-pick-next-page ()
+"Go to the next page.  If at the end of the buffer, start reading articles."
+(interactive)
+(let ((scroll-in-place nil))
+(condition-case nil
+	(scroll-up)
+(end-of-buffer (gnus-pick-start-reading)))))
 ;;;
 ;;; gnus-binary-mode
 ;;;
 (defvar gnus-binary-mode nil
-"Minor mode for provind a binary group interface in Gnus summary buffers.")
+"Minor mode for providing a binary group interface in Gnus summary buffers.")
 (defvar gnus-binary-mode-hook nil
 "Hook run in summary binary mode buffers.")
 (defvar gnus-binary-mode-map nil)
 (make-local-variable 'gnus-auto-select-first)
 (setq gnus-auto-select-first nil)
 (make-local-variable 'gnus-summary-display-article-function)
 (setq gnus-summary-display-article-function 'gnus-binary-display-article)
 ;; Set up the menu.
-(when (and menu-bar-mode
+(when (gnus-visual-p 'binary-menu 'menu)
-		 (gnus-visual-p 'binary-menu 'menu))
 	(gnus-binary-make-menu-bar))
 (unless (assq 'gnus-binary-mode minor-mode-alist)
 	(push '(gnus-binary-mode " Binary") minor-mode-alist))
 (unless (assq 'gnus-binary-mode minor-mode-map-alist)
 	(push (cons 'gnus-binary-mode gnus-binary-mode-map)
 (defvar gnus-tree-brackets '((?\[ . ?\]) (?\( . ?\))
 			     (?\{ . ?\}) (?< . ?>))
 "Brackets used in tree nodes.")
 (defvar gnus-tree-parent-child-edges '(?- ?\\ ?|)
-"Charaters used to connect parents with children.")
+"Characters used to connect parents with children.")
 (defvar gnus-tree-mode-line-format "Gnus: %%b %S %Z"
 "*The format specification for the tree mode line.")
 (defvar gnus-generate-tree-function 'gnus-generate-vertical-tree
 	(gnus-parse-format gnus-tree-mode-line-format
 			   gnus-summary-mode-line-format-alist))
 (setq gnus-tree-line-format-spec
 	(gnus-parse-format gnus-tree-line-format
 			   gnus-tree-line-format-alist t))
-(when (and menu-bar-mode
+(when (gnus-visual-p 'tree-menu 'menu)
-	     (gnus-visual-p 'tree-menu 'menu))
 (gnus-tree-make-menu-bar))
 (kill-all-local-variables)
 (gnus-simplify-mode-line)
 (setq mode-name "Tree")
 (setq major-mode 'gnus-tree-mode)
 (select-window tree-window)
 (when gnus-selected-tree-overlay
 	(goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1)))
 (let* ((top (cond ((< (window-height) 4) 0)
 			((< (window-height) 7) 1)
 			(t 2)))
 	     (height (1- (window-height)))
 	     (bottom (save-excursion (goto-char (point-max))
 				     (forward-line (- height))
 				     (point))))
 	;; Set the window start to either `bottom', which is the biggest
 	     (not (one-window-p)))
 (let ((windows 0)
 	  tot-win-height)
 (walk-windows (lambda (window) (incf windows)))
 (setq tot-win-height
 	    (- (frame-height)
 	       (* window-min-height (1- windows))
 	       2))
 (let* ((window-min-height 2)
 	     (height (count-lines (point-min) (point-max)))
 	     (min (max (1- window-min-height) height))
 	     (wh (and win (1- (window-height win)))))
 	(setq tot (min tot tot-win-height))
 	(when (and win
 		   (not (eq tot wh)))
 	  (let ((selected (selected-window)))
-	    (select-window win)
+	    (when (ignore-errors (select-window win))
-	    (enlarge-window (- tot wh))
+	      (enlarge-window (- tot wh))
-	    (select-window selected)))))))
+	      (select-window selected))))))))
 ;;; Generating the tree.
 (defun gnus-tree-node-insert (header sparse &optional adopted)
 (let* ((dummy (stringp header))
 		  (substring gnus-tmp-from 0 beg))))
 	   ((memq gnus-tmp-number sparse)
 	    "***")
 	   (t gnus-tmp-from)))
 	 (gnus-tmp-open-bracket
 	  (cond ((memq gnus-tmp-number sparse)
 		 (caadr gnus-tree-brackets))
 		(dummy (caaddr gnus-tree-brackets))
 		(adopted (car (nth 3 gnus-tree-brackets)))
 		(t (caar gnus-tree-brackets))))
 	 (gnus-tmp-close-bracket
 	  (insert (car gnus-tree-parent-child-edges))
 	;; If the level isn't zero, then we insert some indentation.
 	(unless (zerop level)
 	  (gnus-tree-indent level)
 	  (insert (cadr gnus-tree-parent-child-edges))
-	  (setq col (- (setq beg (point)) (gnus-point-at-bol) 1))
+	  (setq col (- (setq beg (point)) (point-at-bol) 1))
 	  ;; Draw "|" lines upwards.
 	  (while (progn
 		   (forward-line -1)
 		   (forward-char col)
 		   (= (following-char) ? ))
 	(unless (bolp)
 	  (insert "\n"))
 ;; Recurse downwards in all children of this article.
 (while thread
 	(gnus-generate-horizontal-tree
 	 (pop thread) (if do (1+ level) level)
 	 (or dummyp dummy) dummy)))))
 (defsubst gnus-tree-indent-vertical ()
 (let ((len (- (* (1+ gnus-tree-node-length) gnus-tmp-indent)
-		(- (point) (gnus-point-at-bol)))))
+		(- (point) (point-at-bol)))))
 (when (> len 0)
 (insert (make-string len ? )))))
 (defsubst gnus-tree-forward-line (n)
 (while (>= (decf n) 0)
 (defun gnus-generate-vertical-tree (thread level &optional dummyp adopted)
 "Generate a vertical tree."
 (let* ((dummy (stringp (car thread)))
 	 (do (or dummy
-		 (memq (mail-header-number (car thread)) gnus-tmp-limit)))
+		 (and (car thread)
+		      (memq (mail-header-number (car thread))
+			    gnus-tmp-limit))))
 	 beg)
 (if (not do)
 	;; We don't want this article.
 	(setq thread (cdr thread))
 (if (not (save-excursion (beginning-of-line) (bobp)))
 	  (delete-char -1)
 	  (insert (cadr gnus-tree-parent-child-edges))
 	  (setq beg (point))
 	  ;; Draw "-" lines leftwards.
 	  (while (progn
-		   (forward-char -2)
+		   (unless (bolp)
+		     (forward-char -2))
 		   (= (following-char) ? ))
 	    (delete-char 1)
 	    (insert (car gnus-tree-parent-child-edges)))
 	  (goto-char beg)
 	  (gnus-tree-forward-line 1)))
 	  (end-of-line)
 	  (incf gnus-tmp-indent))
 ;; Recurse downwards in all children of this article.
 (while thread
 	(gnus-generate-vertical-tree
 	 (pop thread) (if do (1+ level) level)
 	 (or dummyp dummy) dummy)))))
 ;;; Interface functions.
 (defun gnus-possibly-generate-tree (article &optional force)
 "Generate the thread tree for ARTICLE if it isn't displayed already."
 (when (save-excursion
 	  (set-buffer gnus-summary-buffer)
 	  (and gnus-use-trees
+	       gnus-show-threads
 	       (vectorp (gnus-summary-article-header article))))
 (save-excursion
 (let ((top (save-excursion
 		   (set-buffer gnus-summary-buffer)
 		   (gnus-cut-thread
 		    (gnus-remove-thread
 		     (mail-header-id
-		      (gnus-summary-article-header article)) t))))
+		      (gnus-summary-article-header article))
+		     t))))
 	    (gnus-tmp-limit gnus-newsgroup-limit)
 	    (gnus-tmp-sparse gnus-newsgroup-sparse))
 	(when (or force
 		  (not (eq top gnus-tree-displayed-thread)))
 	  (gnus-generate-tree top)
 (defun gnus-tree-open (group)
 (gnus-get-tree-buffer))
 (defun gnus-tree-close (group)
-;(gnus-kill-buffer gnus-tree-buffer)
+					;(gnus-kill-buffer gnus-tree-buffer)
 )
 (defun gnus-highlight-selected-tree (article)
 "Highlight the selected article in the tree."
 (let ((buf (current-buffer))
 (when (setq region (gnus-tree-article-region article))
 	(gnus-put-text-property (car region) (cdr region) 'face face)
 	(set-window-point
 	 (get-buffer-window (current-buffer) t) (cdr region))))))
+;;;
+;;; gnus-carpal
+;;;
+(defvar gnus-carpal-group-buffer-buttons
+'(("next" . gnus-group-next-unread-group)
+("prev" . gnus-group-prev-unread-group)
+("read" . gnus-group-read-group)
+("select" . gnus-group-select-group)
+("catch-up" . gnus-group-catchup-current)
+("new-news" . gnus-group-get-new-news-this-group)
+("toggle-sub" . gnus-group-unsubscribe-current-group)
+("subscribe" . gnus-group-unsubscribe-group)
+("kill" . gnus-group-kill-group)
+("yank" . gnus-group-yank-group)
+("describe" . gnus-group-describe-group)
+"list"
+("subscribed" . gnus-group-list-groups)
+("all" . gnus-group-list-all-groups)
+("killed" . gnus-group-list-killed)
+("zombies" . gnus-group-list-zombies)
+("matching" . gnus-group-list-matching)
+("post" . gnus-group-post-news)
+("mail" . gnus-group-mail)
+("rescan" . gnus-group-get-new-news)
+("browse-foreign" . gnus-group-browse-foreign)
+("exit" . gnus-group-exit)))
+(defvar gnus-carpal-summary-buffer-buttons
+'("mark"
+("read" . gnus-summary-mark-as-read-forward)
+("tick" . gnus-summary-tick-article-forward)
+("clear" . gnus-summary-clear-mark-forward)
+("expirable" . gnus-summary-mark-as-expirable)
+"move"
+("scroll" . gnus-summary-next-page)
+("next-unread" . gnus-summary-next-unread-article)
+("prev-unread" . gnus-summary-prev-unread-article)
+("first" . gnus-summary-first-unread-article)
+("best" . gnus-summary-best-unread-article)
+"article"
+("headers" . gnus-summary-toggle-header)
+("uudecode" . gnus-uu-decode-uu)
+("enter-digest" . gnus-summary-enter-digest-group)
+("fetch-parent" . gnus-summary-refer-parent-article)
+"mail"
+("move" . gnus-summary-move-article)
+("copy" . gnus-summary-copy-article)
+("respool" . gnus-summary-respool-article)
+"threads"
+("lower" . gnus-summary-lower-thread)
+("kill" . gnus-summary-kill-thread)
+"post"
+("post" . gnus-summary-post-news)
+("mail" . gnus-summary-mail)
+("followup" . gnus-summary-followup-with-original)
+("reply" . gnus-summary-reply-with-original)
+("cancel" . gnus-summary-cancel-article)
+"misc"
+("exit" . gnus-summary-exit)
+("fed-up" . gnus-summary-catchup-and-goto-next-group)))
+(defvar gnus-carpal-server-buffer-buttons
+'(("add" . gnus-server-add-server)
+("browse" . gnus-server-browse-server)
+("list" . gnus-server-list-servers)
+("kill" . gnus-server-kill-server)
+("yank" . gnus-server-yank-server)
+("copy" . gnus-server-copy-server)
+("exit" . gnus-server-exit)))
+(defvar gnus-carpal-browse-buffer-buttons
+'(("subscribe" . gnus-browse-unsubscribe-current-group)
+("exit" . gnus-browse-exit)))
+(defvar gnus-carpal-group-buffer "*Carpal Group*")
+(defvar gnus-carpal-summary-buffer "*Carpal Summary*")
+(defvar gnus-carpal-server-buffer "*Carpal Server*")
+(defvar gnus-carpal-browse-buffer "*Carpal Browse*")
+(defvar gnus-carpal-attached-buffer nil)
+(defvar gnus-carpal-mode-hook nil
+"*Hook run in carpal mode buffers.")
+(defvar gnus-carpal-button-face 'bold
+"*Face used on carpal buttons.")
+(defvar gnus-carpal-header-face 'bold-italic
+"*Face used on carpal buffer headers.")
+(defvar gnus-carpal-mode-map nil)
+(put 'gnus-carpal-mode 'mode-class 'special)
+(if gnus-carpal-mode-map
+nil
+(setq gnus-carpal-mode-map (make-keymap))
+(suppress-keymap gnus-carpal-mode-map)
+(define-key gnus-carpal-mode-map " " 'gnus-carpal-select)
+(define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select)
+(define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select))
+(defun gnus-carpal-mode ()
+"Major mode for clicking buttons.
+All normal editing commands are switched off.
+\\<gnus-carpal-mode-map>
+The following commands are available:
+\\{gnus-carpal-mode-map}"
+(interactive)
+(kill-all-local-variables)
+(setq mode-line-modified "-- ")
+(setq major-mode 'gnus-carpal-mode)
+(setq mode-name "Gnus Carpal")
+(setq mode-line-process nil)
+(use-local-map gnus-carpal-mode-map)
+(buffer-disable-undo (current-buffer))
+(setq buffer-read-only t)
+(make-local-variable 'gnus-carpal-attached-buffer)
+(run-hooks 'gnus-carpal-mode-hook))
+(defun gnus-carpal-setup-buffer (type)
+(let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type)))))
+(if (get-buffer buffer)
+	()
+(save-excursion
+	(set-buffer (get-buffer-create buffer))
+	(gnus-carpal-mode)
+	(setq gnus-carpal-attached-buffer
+	      (intern (format "gnus-%s-buffer" type)))
+	(gnus-add-current-to-buffer-list)
+	(let ((buttons (symbol-value
+			(intern (format "gnus-carpal-%s-buffer-buttons"
+					type))))
+	      (buffer-read-only nil)
+	      button)
+	  (while buttons
+	    (setq button (car buttons)
+		  buttons (cdr buttons))
+	    (if (stringp button)
+		(gnus-set-text-properties
+		 (point)
+		 (prog2 (insert button) (point) (insert " "))
+		 (list 'face gnus-carpal-header-face))
+	      (gnus-set-text-properties
+	       (point)
+	       (prog2 (insert (car button)) (point) (insert " "))
+	       (list 'gnus-callback (cdr button)
+		     'face gnus-carpal-button-face
+		     gnus-mouse-face-prop 'highlight))))
+	  (let ((fill-column (- (window-width) 2)))
+	    (fill-region (point-min) (point-max)))
+	  (set-window-point (get-buffer-window (current-buffer))
+			    (point-min)))))))
+(defun gnus-carpal-select ()
+"Select the button under point."
+(interactive)
+(let ((func (get-text-property (point) 'gnus-callback)))
+(if (null func)
+	()
+(pop-to-buffer (symbol-value gnus-carpal-attached-buffer))
+(call-interactively func))))
+(defun gnus-carpal-mouse-select (event)
+"Select the button under the mouse pointer."
+(interactive "e")
+(mouse-set-point event)
+(gnus-carpal-select))
 ;;; Allow redefinition of functions.
 (gnus-ems-redefine)
 (provide 'gnus-salt)

Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-salt.el @ 16:0293115a14e9 r19-15b91