;;; Mouse, font and toolbar support for GNUS running in XEmacs
;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
;; Copyright (C) 1995 Richard Cognot

;; This file is part of XEmacs.

;; XEmacs 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 2, or (at your option)
;; any later version.

;; XEmacs 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 XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;; Richard Cognot provided the toolbar support:
;;     Right now, no down or disabled icons are provided, but just
;;     adding them to the icon directory will be enough for them to
;;     be loaded.  Context-sensitive setting of up/down/inactive
;;     icons not done.

;;; Right button pops up a menu of commands in Newsgroup and Summary buffers.
;;; Middle button selects indicated newsgroup or article.

(defvar gnus-summary-menu
  '("GNUS Summary Commands"
    ["Select Article / Next Page" gnus-summary-next-page t]
    ["Prev Page" gnus-summary-prev-page t]
    ["Select Parent Article" gnus-summary-refer-parent-article t]
    "----"
    ["Beginning of Article" gnus-summary-beginning-of-article t]
    ["End of Article" gnus-summary-end-of-article t]
    ["Show All Headers" gnus-summary-show-all-headers t]
    ["ROT13 Article" gnus-summary-caesar-message t]
    ["Save Article to Mail File" gnus-summary-save-in-mail t]
    ("Sort Articles"
     ["Sort By Author" gnus-summary-sort-by-author t]
     ["Sort By Date" gnus-summary-sort-by-date t]
     ["Sort By Number" gnus-summary-sort-by-number t]
     ["Sort By Subject" gnus-summary-sort-by-subject t])
    "----"
    ["Mail Reply" gnus-summary-reply t]
    ["Mail Reply (Citing Original)" gnus-summary-reply-with-original t]
    ["Post Reply" gnus-summary-followup t]
    ["Post Reply (Citing Original)" gnus-summary-followup-with-original t]
    ["Post New Article" gnus-summary-post-news t]
    ["Forward Article" gnus-summary-mail-forward t]
    "----"
    ["Show Toolbar" (gnus-toggle-toolbar gnus-summary-toolbar)
     :style toggle :selected (gnus-toolbar-active)]
    "----"
    ["Mark Article as Read" gnus-summary-mark-as-read-forward t]
    ["Mark Article as Unread" gnus-summary-mark-as-unread-backward t]
    ["Mark Similar Subjects as Read" gnus-summary-kill-same-subject t]
    ["Quit this Newsgroup" gnus-summary-exit t]
    ["Quit this Newsgroup (mark everything as read)"
     gnus-summary-catchup-and-exit t]
    ))

(defvar gnus-group-menu
  '("GNUS Group Commands"
    ["Select Newsgroup" gnus-group-read-group t]
    ["Unsubscribe Newsgroup" gnus-group-unsubscribe-current-group t]
    ["Get New News" gnus-group-get-new-news t]
    "----"
    ["Mark Newsgroup as Read" gnus-group-catchup t]
    ["Mark All Newsgroups as Read" gnus-group-catchup-all t]
    ["Show All Newsgroups" gnus-group-list-all-groups t]
    ["Show Subscribed Nonempty Newsgroups" gnus-group-list-groups t]
    ["Check Bogosity" gnus-group-check-bogus-groups t]
    "----"
    ["Post New Article" gnus-group-post-news t]
    "----"
    ["Show Toolbar" (gnus-toggle-toolbar gnus-groups-toolbar)
     :style toggle :selected (gnus-toolbar-active)]
    "----"
    ["Save .newsrc" gnus-group-force-update t]
    ["GNUS Manual" gnus-info-find-node t]
    ["Suspend GNUS" gnus-group-suspend t]
    ["Quit GNUS" gnus-group-exit t]
    ))

(defvar gnus-article-menu 
  '("GNUS Article Commands"
    ["Next Page" gnus-article-next-page t]
    ["Previous Page" gnus-article-prev-page t]
    ["Pop Article History" gnus-article-pop-article t]
    ["Show Referenced Article" gnus-article-refer-article t]
    ["Show Summary" gnus-article-show-summary t]
    "----"
    ["Mail Reply" gnus-summary-reply t]
    ["Mail Reply (Citing Original)" gnus-summary-reply-with-original t]
    ["Post Reply" gnus-summary-followup t]
    ["Post Reply (Citing Original)" gnus-summary-followup-with-original t]
    ["Forward Article" gnus-summary-mail-forward t]
    ))

(defun gnus-summary-menu (e)
  (interactive "e")
  (mouse-set-point e)
  (beginning-of-line)
  (search-forward ":" nil t)
  (popup-menu gnus-summary-menu))

(defun gnus-group-menu (e)
  (interactive "e")
  (mouse-set-point e)
  (beginning-of-line)
  (search-forward ":" nil t)
  (popup-menu gnus-group-menu))

(defun gnus-article-menu (e)
  (interactive "@e")
  (popup-menu gnus-article-menu))

(defun gnus-group-mouse-read-group (e)
  (interactive "e")
  (mouse-set-point e)
  (beginning-of-line)
  (search-forward ":" nil t)
  (gnus-group-read-group nil))

(defun gnus-summary-mouse-next-page (e)
  (interactive "e")
  (mouse-set-point e)
  (beginning-of-line)
  (search-forward ":" nil t)
  (gnus-summary-next-page nil))

(define-key gnus-summary-mode-map 'button2 'gnus-summary-mouse-next-page)
(define-key gnus-group-mode-map   'button2 'gnus-group-mouse-read-group)

(define-key gnus-summary-mode-map 'button3 'gnus-summary-menu)
(define-key gnus-group-mode-map   'button3 'gnus-group-menu)
(define-key gnus-article-mode-map 'button3 'gnus-article-menu)


;;; Put message headers in boldface, etc...

(require 'highlight-headers)

(defun gnus-fontify-headers ()
  (save-excursion
    (set-buffer gnus-article-buffer)
    (save-excursion
      (save-restriction
	(widen)
	(highlight-headers (point-min) (point-max) t)))))

(make-face 'gnus-underline)
(or (face-differs-from-default-p 'gnus-underline)
    (set-face-underline-p 'gnus-underline t))

(defun gnus-hack-underlining ()
  "replaces underscore-backspace with an extent.
Also removes the extra blank lines from the article."
  (save-excursion
    (set-buffer gnus-article-buffer)
    (goto-char (point-min))
    (while (re-search-forward "\\(\\(_\^H.\\) ?\\)+" nil t)
      (set-extent-face (make-extent (match-beginning 0) (match-end 0))
		       'gnus-underline))
    (goto-char (point-min))
    (while (re-search-forward "_\^H" nil t) (replace-match ""))))

(defun gnus-hack-clarinews ()
  (if (string-match "^clari\\.*\\|^biz\\.clarinet" gnus-newsgroup-name)
      (save-excursion
	(gnus-hack-underlining)
	(set-buffer gnus-article-buffer)
	(goto-char (point-min))
        (while (re-search-forward "\n\n\n\n*" nil t)
          (replace-match "\n\n")))))

(add-hook 'gnus-select-article-hook 'gnus-fontify-headers)
(add-hook 'gnus-article-prepare-hook 'gnus-hack-clarinews)


;;; Fontify the Newsgroups and Summary buffers
;;; Enable this either of these by turning on font-lock-mode:
;;;
;;;	(add-hook 'gnus-group-mode-hook   'turn-on-font-lock)
;;;	(add-hook 'gnus-summary-mode-hook 'turn-on-font-lock)
;;;
;;; Fontifying the *Newsgroups* buffer makes `gnus-group-list-all-groups'
;;; be awfully slow (about 50 seconds to display 2782 groups on a Sparc10.)
;;; But it's fairly fast for day-to-day use if you only subscribe to a few
;;; hundred newsgroups.
;;;
;;; Fontifying the *Summary* buffer is about the same speed (per line) as
;;; the *Newsgroups* buffer, but since it's rare to ever select more than
;;; a few hundred articles, it's not so bad. (For ~100 articles it only 
;;; takes ~2 seconds.)
;;;
;;; Possibly this could be optimized by doing the same sort of trick that
;;; we did with dired-indent-rigidly (that is, inhibit the after-change-
;;; function until the whole buffer has been generated) but preliminary
;;; tests suggest that what this would actually save is negligible.

(defconst gnus-summary-font-lock-keywords
  '(
    ;; This is how you put the article number in another face
    ;;("^..[^0-9*]*\\([0-9]+\\):"
    ;; 1 message-highlighted-header-contents)
    ;; This matches the part between [] after optional something-digits-colon
    ("^[^[]+\\[\\([^A-Za-z\n]*[0-9]+:\\)?\\([^[\n]*\\)\\]"
     2 message-headers)
    ;; This matches the part after the first ]
    ("^[^]\n]+\\]\\(.*\\)" 1 message-header-contents)
    ))

(defconst gnus-group-font-lock-keywords
  '(
    ;; This is how you put the number of  articles in another face
    ;;("^..[^0-9*]*\\([0-9]+\\):" 1 message-headers)
    ;; This matches the part after the first :
    (": \\(.*\\)" 1 message-header-contents)
    ))

;;; Highlight the line under the mouse in the Newsgroup and Summary buffers.

(defun gnus-install-mouse-tracker ()
  (require 'mode-motion)
  (setq mode-motion-hook 'mode-motion-highlight-line))

(add-hook 'gnus-summary-mode-hook 'gnus-install-mouse-tracker)
(add-hook 'gnus-group-mode-hook   'gnus-install-mouse-tracker)


;;; Put the GNUS menus in the menubar

(defun gnus-install-menubar ()
  (if (and current-menubar (not (assoc "GNUS" current-menubar)))
      (let ((menu (cond ((eq major-mode 'gnus-group-mode) gnus-group-menu)
			((eq major-mode 'gnus-summary-mode) gnus-summary-menu)
			(t (error "not GNUS Group or Summary mode")))))
	(set-buffer-menubar (copy-sequence current-menubar))
	(add-menu nil "GNUS" (cdr menu)))))

(add-hook 'gnus-summary-mode-hook 'gnus-install-menubar)
(add-hook 'gnus-group-mode-hook   'gnus-install-menubar)


;;; Setup the GNUS toolbar and associated vars.

(defvar gnus-toolbar-icon-directory nil
  "Where the toolbar icons for GNUS are.")

(defvar gnus-toolbar-exit-icon nil 
  "Toolbar icon for unsubscribe newsgroup")
(defvar gnus-toolbar-unsubscribe-newsgroup-icon nil 
  "Toolbar icon for unsubscribe newsgroup")
(defvar gnus-toolbar-get-new-news-icon nil 
  "Toolbar icon for unsubscribe newsgroup")
(defvar gnus-toolbar-catchup-newsgroup-icon nil 
  "Toolbar icon for catchup newsgroup")
(defvar gnus-toolbar-read-newsgroup-icon nil 
  "Toolbar icon for read newsgroup")
(defvar gnus-toolbar-next-newsgroup-icon nil 
  "Toolbar icon for next unread newsgroup")
(defvar gnus-toolbar-prev-newsgroup-icon nil 
  "Toolbar icon for previous unread newsgroup")
(defvar gnus-toolbar-next-article-icon nil 
  "Toolbar icon for next unread article")
(defvar gnus-toolbar-prev-article-icon nil 
  "Toolbar icon for previous unread article")
(defvar gnus-toolbar-kill-icon nil 
  "Toolbar icon for kill article")
(defvar gnus-toolbar-kill-thread-icon nil 
  "Toolbar icon for kill thread")
(defvar gnus-toolbar-reply-article-icon nil 
  "Toolbar icon for reply to article")
(defvar gnus-toolbar-followup-article-icon nil 
  "Toolbar icon for followup to article")
(defvar gnus-toolbar-post-article-icon nil 
  "Toolbar icon for post new article")

(defvar gnus-toolbar-orientation 'default
  "*Where to put the GNUS toolbar.  Must be one of these symbols:

default -- place at location specified by function `default-toolbar-position'
top     -- place along the top of the frame
bottom  -- place along the bottom of the frame
right   -- place along the right edge of the frame
left    -- place along the left edge of the frame
none	-- no toolbar")

(defvar gnus-groups-toolbar
  '(
    [gnus-toolbar-exit-icon
     gnus-group-exit t "Exit GNUS"]
    [gnus-toolbar-get-new-news-icon 
     gnus-group-get-new-news t "Get new news"]
    [gnus-toolbar-prev-newsgroup-icon
     gnus-group-prev-unread-group t "Previous unread group"]
    [gnus-toolbar-next-newsgroup-icon
     gnus-group-next-unread-group t "Next unread group"]
    [gnus-toolbar-read-newsgroup-icon
     gnus-group-read-group t "Read current group"]
    [gnus-toolbar-catchup-newsgroup-icon
     gnus-group-catchup t "Catchup current group"]
    [gnus-toolbar-unsubscribe-newsgroup-icon 
     gnus-group-unsubscribe-current-group t "Unsubscribe group"]
   )
  "The toolbar for GNUS summary mode.")

(defvar gnus-summary-toolbar
  '(
    [gnus-toolbar-exit-icon
     gnus-summary-exit t "Exit newsgroup"]
    [gnus-toolbar-catchup-newsgroup-icon
     gnus-summary-catchup-and-exit t "Catchup current group"]
    [gnus-toolbar-prev-article-icon
     gnus-summary-prev-unread-article t "Previous unread message"]
    [gnus-toolbar-next-article-icon
     gnus-summary-next-unread-article t "Next unread message"]
    [gnus-toolbar-kill-article-icon 
     gnus-summary-mark-as-read-forward t "Kill article"]
    [gnus-toolbar-kill-thread-icon 
     gnus-summary-kill-same-subject-and-select t "Kill thread"]
    [gnus-toolbar-reply-article-icon 
     gnus-summary-reply-with-original t "Reply to sender"]
    [gnus-toolbar-followup-article-icon 
     gnus-summary-followup-with-original t "Followup"]
    [gnus-toolbar-post-article-icon 
     gnus-summary-post-news t "Post new article"]
   )
  "The toolbar for GNUS summary mode.")

(defun gnus-toolbar-active ()
  (interactive)
  (if (featurep 'toolbar)
      (let ((toolbar (gnus-toolbar-from-orientation gnus-toolbar-orientation)))
	(if (specifier-instance toolbar)
	    t
	  nil))
    nil))

(defun gnus-toggle-toolbar (toolbar)
  (interactive)
  (if (featurep 'toolbar)
      (let ((toolbar-obj (gnus-toolbar-from-orientation
			  gnus-toolbar-orientation)))
	(if (gnus-toolbar-active)
	    (set-specifier toolbar-obj (cons (current-buffer) nil))
	  (set-specifier toolbar-obj (cons (current-buffer) toolbar))))))

(defun gnus-toolbar-init ()
  "Set up GNUS toolbar"
  (if (not (featurep 'toolbar))
      nil
    (if (not gnus-toolbar-icon-directory)
	(setq gnus-toolbar-icon-directory
	      (file-name-as-directory
	       (expand-file-name "gnus" data-directory))))
    (if (not (file-exists-p gnus-toolbar-icon-directory))
	(message "Toolbar directory does not exist.")
      (if (fboundp 'toolbar-make-button-list)
	  (mapcar
	   (function
	    (lambda (x)
	      (let* ((ext (if (featurep 'xpm) ".xpm" ".xbm"))
		     (base gnus-toolbar-icon-directory)
		     (up (expand-file-name (concat x "-up" ext) base))
		     (dn (expand-file-name (concat x "-dn" ext) base))
		     (var (intern (concat "gnus-toolbar-" x "-icon")))
		     (no (expand-file-name (concat x "-no" ext) base)))
		(set var
		     (cond
		      ((and (file-exists-p up) (file-exists-p dn)
			    (file-exists-p no))
		       (toolbar-make-button-list up dn no))
		      ((file-exists-p up)
		       (toolbar-make-button-list up))
		      (t nil))))))
	   '("exit" "unsubscribe-newsgroup" "get-new-news" "catchup-newsgroup" 
	     "read-newsgroup" "next-newsgroup" "prev-newsgroup"
	     "next-article" "prev-article" "kill-article" "kill-thread"
	     "reply-article" "followup-article" "post-article"))))))

(defun gnus-toolbar-from-orientation (orientation)
  (cond
   ((eq 'default gnus-toolbar-orientation) default-toolbar)
   ((eq 'bottom gnus-toolbar-orientation) bottom-toolbar)
   ((eq 'top gnus-toolbar-orientation) top-toolbar)
   ((eq 'left gnus-toolbar-orientation) left-toolbar)
   ((eq 'right gnus-toolbar-orientation) right-toolbar)))

(defun gnus-set-toolbar-internal (toolbar)
  (if (not (featurep 'toolbar))
      nil
    (if (not gnus-toolbar-exit-icon)
	(gnus-toolbar-init))
    (if (fboundp 'set-specifier)
	(let ((toolbar-obj
	       (gnus-toolbar-from-orientation gnus-toolbar-orientation)))
	  (if toolbar-obj
	      (set-specifier toolbar-obj (cons (current-buffer) toolbar)))))))

(defun gnus-toolbar-set-groups-toolbar ()
  "Set GNUS toolbar in group buffer."
  (gnus-set-toolbar-internal gnus-groups-toolbar))

(defun gnus-toolbar-set-summary-toolbar ()
  "Set GNUS toolbar in summary buffer."
  (gnus-set-toolbar-internal gnus-summary-toolbar))

(add-hook 'gnus-summary-mode-hook 'gnus-toolbar-set-summary-toolbar)
(add-hook 'gnus-group-mode-hook 'gnus-toolbar-set-groups-toolbar)


(provide 'gnus-xemacs)
