cgit.sxemacs.org Git - gnus/blob - lisp/gnus-win.el

   1 ;;; gnus-win.el --- window configuration functions for Gnus
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29
  30 (require 'gnus)
  31 (require 'gnus-util)
  32
  33 (defgroup gnus-windows nil
  34   "Window configuration."
  35   :group 'gnus)
  36
  37 (defcustom gnus-use-full-window t
  38   "*If non-nil, use the entire Emacs screen."
  39   :group 'gnus-windows
  40   :type 'boolean)
  41
  42 (defvar gnus-window-configuration nil
  43   "Obsolete variable.  See `gnus-buffer-configuration'.")
  44
  45 (defcustom gnus-window-min-width 2
  46   "*Minimum width of Gnus buffers."
  47   :group 'gnus-windows
  48   :type 'integer)
  49
  50 (defcustom gnus-window-min-height 1
  51   "*Minimum height of Gnus buffers."
  52   :group 'gnus-windows
  53   :type 'integer)
  54
  55 (defcustom gnus-always-force-window-configuration nil
  56   "*If non-nil, always force the Gnus window configurations."
  57   :group 'gnus-windows
  58   :type 'boolean)
  59
  60 (defcustom gnus-use-frames-on-any-display nil
  61   "*If non-nil, frames on all displays will be considered useable by Gnus.
  62 When nil, only frames on the same display as the selected frame will be
  63 used to display Gnus windows."
  64   :version "22.1"
  65   :group 'gnus-windows
  66   :type 'boolean)
  67
  68 (defvar gnus-buffer-configuration
  69   '((group
  70      (vertical 1.0
  71                (group 1.0 point)))
  72     (summary
  73      (vertical 1.0
  74                (summary 1.0 point)))
  75     (article
  76      (cond
  77       (gnus-use-trees
  78        '(vertical 1.0
  79                   (summary 0.25 point)
  80                   (tree 0.25)
  81                   (article 1.0)))
  82       (t
  83        '(vertical 1.0
  84                   (summary 0.25 point)
  85                   (article 1.0)))))
  86     (server
  87      (vertical 1.0
  88                (server 1.0 point)))
  89     (browse
  90      (vertical 1.0
  91                (browse 1.0 point)))
  92     (message
  93      (vertical 1.0
  94                (message 1.0 point)))
  95     (pick
  96      (vertical 1.0
  97                (article 1.0 point)))
  98     (info
  99      (vertical 1.0
 100                (info 1.0 point)))
 101     (summary-faq
 102      (vertical 1.0
 103                (summary 0.25)
 104                (faq 1.0 point)))
 105     (only-article
 106      (vertical 1.0
 107                (article 1.0 point)))
 108     (edit-article
 109      (vertical 1.0
 110                (article 1.0 point)))
 111     (edit-form
 112      (vertical 1.0
 113                (group 0.5)
 114                (edit-form 1.0 point)))
 115     (edit-score
 116      (vertical 1.0
 117                (summary 0.25)
 118                (edit-score 1.0 point)))
 119     (edit-server
 120      (vertical 1.0
 121                (server 0.5)
 122                (edit-form 1.0 point)))
 123     (post
 124      (vertical 1.0
 125                (post 1.0 point)))
 126     (reply
 127      (vertical 1.0
 128                (article 0.5)
 129                (message 1.0 point)))
 130     (forward
 131      (vertical 1.0
 132                (message 1.0 point)))
 133     (reply-yank
 134      (vertical 1.0
 135                (message 1.0 point)))
 136     (mail-bounce
 137      (vertical 1.0
 138                (article 0.5)
 139                (message 1.0 point)))
 140     (pipe
 141      (vertical 1.0
 142                (summary 0.25 point)
 143                ("*Shell Command Output*" 1.0)))
 144     (bug
 145      (vertical 1.0
 146                (if gnus-bug-create-help-buffer '("*Gnus Help Bug*" 0.5))
 147                ("*Gnus Bug*" 1.0 point)))
 148     (score-trace
 149      (vertical 1.0
 150                (summary 0.5 point)
 151                ("*Score Trace*" 1.0)))
 152     (score-words
 153      (vertical 1.0
 154                (summary 0.5 point)
 155                ("*Score Words*" 1.0)))
 156     (split-trace
 157      (vertical 1.0
 158                (summary 0.5 point)
 159                ("*Split Trace*" 1.0)))
 160     (category
 161      (vertical 1.0
 162                (category 1.0)))
 163     (compose-bounce
 164      (vertical 1.0
 165                (article 0.5)
 166                (message 1.0 point)))
 167     (display-term
 168      (vertical 1.0
 169                ("*display*" 1.0)))
 170     (mml-preview
 171      (vertical 1.0
 172                (message 0.5)
 173                (mml-preview 1.0 point))))
 174   "Window configuration for all possible Gnus buffers.
 175 See the Gnus manual for an explanation of the syntax used.")
 176
 177 (defvar gnus-window-to-buffer
 178   '((group . gnus-group-buffer)
 179     (summary . gnus-summary-buffer)
 180     (article . gnus-article-buffer)
 181     (server . gnus-server-buffer)
 182     (browse . "*Gnus Browse Server*")
 183     (edit-group . gnus-group-edit-buffer)
 184     (edit-form . gnus-edit-form-buffer)
 185     (edit-server . gnus-server-edit-buffer)
 186     (edit-score . gnus-score-edit-buffer)
 187     (message . gnus-message-buffer)
 188     (mail . gnus-message-buffer)
 189     (post-news . gnus-message-buffer)
 190     (faq . gnus-faq-buffer)
 191     (tree . gnus-tree-buffer)
 192     (score-trace . "*Score Trace*")
 193     (split-trace . "*Split Trace*")
 194     (info . gnus-info-buffer)
 195     (category . gnus-category-buffer)
 196     (article-copy . gnus-article-copy)
 197     (draft . gnus-draft-buffer)
 198     (mml-preview . mml-preview-buffer))
 199   "Mapping from short symbols to buffer names or buffer variables.")
 200
 201 (defcustom gnus-configure-windows-hook nil
 202   "*A hook called when configuring windows."
 203   :version "22.1"
 204   :group 'gnus-windows
 205   :type 'hook)
 206
 207 ;;; Internal variables.
 208
 209 (defvar gnus-current-window-configuration nil
 210   "The most recently set window configuration.")
 211
 212 (defvar gnus-created-frames nil)
 213 (defvar gnus-window-frame-focus nil)
 214
 215 (defun gnus-kill-gnus-frames ()
 216   "Kill all frames Gnus has created."
 217   (while gnus-created-frames
 218     (when (frame-live-p (car gnus-created-frames))
 219       ;; We slap a condition-case around this `delete-frame' to ensure
 220       ;; against errors if we try do delete the single frame that's left.
 221       (ignore-errors
 222         (delete-frame (car gnus-created-frames))))
 223     (pop gnus-created-frames)))
 224
 225 (defun gnus-window-configuration-element (list)
 226   (while (and list
 227               (not (assq (car list) gnus-window-configuration)))
 228     (pop list))
 229   (cadr (assq (car list) gnus-window-configuration)))
 230
 231 ;;;###autoload
 232 (defun gnus-add-configuration (conf)
 233   "Add the window configuration CONF to `gnus-buffer-configuration'."
 234   (setq gnus-buffer-configuration
 235         (cons conf (delq (assq (car conf) gnus-buffer-configuration)
 236                          gnus-buffer-configuration))))
 237
 238 (defvar gnus-frame-list nil)
 239
 240 (defun gnus-window-to-buffer-helper (obj)
 241   (cond ((not (symbolp obj))
 242          obj)
 243         ((boundp obj)
 244          (symbol-value obj))
 245         ((fboundp obj)
 246          (funcall obj))
 247         (t
 248          nil)))
 249
 250 (defun gnus-configure-frame (split &optional window)
 251   "Split WINDOW according to SPLIT."
 252   (let* ((current-window (or (get-buffer-window (current-buffer)) (selected-window)))
 253          (window (or window current-window)))
 254     (select-window window)
 255     ;; The SPLIT might be something that is to be evaled to
 256     ;; return a new SPLIT.
 257     (while (and (not (assq (car split) gnus-window-to-buffer))
 258                 (symbolp (car split)) (fboundp (car split)))
 259       (setq split (eval split)))
 260     (let* ((type (car split))
 261            (subs (cddr split))
 262            (len (if (eq type 'horizontal) (window-width) (window-height)))
 263            (total 0)
 264            (window-min-width (or gnus-window-min-width window-min-width))
 265            (window-min-height (or gnus-window-min-height window-min-height))
 266            s result new-win rest comp-subs size sub)
 267       (cond
 268        ;; Nothing to do here.
 269        ((null split))
 270        ;; Don't switch buffers.
 271        ((null type)
 272         (and (memq 'point split) window))
 273        ;; This is a buffer to be selected.
 274        ((not (memq type '(frame horizontal vertical)))
 275         (let ((buffer (cond ((stringp type) type)
 276                             (t (cdr (assq type gnus-window-to-buffer))))))
 277           (unless buffer
 278             (error "Invalid buffer type: %s" type))
 279           (let ((buf (gnus-get-buffer-create
 280                       (gnus-window-to-buffer-helper buffer))))
 281             (if (eq buf (window-buffer (selected-window))) (set-buffer buf)
 282               (switch-to-buffer buf)))
 283           (when (memq 'frame-focus split)
 284             (setq gnus-window-frame-focus window))
 285           ;; We return the window if it has the `point' spec.
 286           (and (memq 'point split) window)))
 287        ;; This is a frame split.
 288        ((eq type 'frame)
 289         (unless gnus-frame-list
 290           (setq gnus-frame-list (list (window-frame current-window))))
 291         (let ((i 0)
 292               params frame fresult)
 293           (while (< i (length subs))
 294             ;; Frame parameter is gotten from the sub-split.
 295             (setq params (cadr (elt subs i)))
 296             ;; It should be a list.
 297             (unless (listp params)
 298               (setq params nil))
 299             ;; Create a new frame?
 300             (unless (setq frame (elt gnus-frame-list i))
 301               (nconc gnus-frame-list (list (setq frame (make-frame params))))
 302               (push frame gnus-created-frames))
 303             ;; Is the old frame still alive?
 304             (unless (frame-live-p frame)
 305               (setcar (nthcdr i gnus-frame-list)
 306                       (setq frame (make-frame params))))
 307             ;; Select the frame in question and do more splits there.
 308             (select-frame frame)
 309             (setq fresult (or (gnus-configure-frame (elt subs i)) fresult))
 310             (incf i))
 311           ;; Select the frame that has the selected buffer.
 312           (when fresult
 313             (select-frame (window-frame fresult)))))
 314        ;; This is a normal split.
 315        (t
 316         (when (> (length subs) 0)
 317           ;; First we have to compute the sizes of all new windows.
 318           (while subs
 319             (setq sub (append (pop subs) nil))
 320             (while (and (not (assq (car sub) gnus-window-to-buffer))
 321                         (symbolp (car sub)) (fboundp (car sub)))
 322               (setq sub (eval sub)))
 323             (when sub
 324               (push sub comp-subs)
 325               (setq size (cadar comp-subs))
 326               (cond ((equal size 1.0)
 327                      (setq rest (car comp-subs))
 328                      (setq s 0))
 329                     ((floatp size)
 330                      (setq s (floor (* size len))))
 331                     ((integerp size)
 332                      (setq s size))
 333                     (t
 334                      (error "Invalid size: %s" size)))
 335               ;; Try to make sure that we are inside the safe limits.
 336               (cond ((zerop s))
 337                     ((eq type 'horizontal)
 338                      (setq s (max s window-min-width)))
 339                     ((eq type 'vertical)
 340                      (setq s (max s window-min-height))))
 341               (setcar (cdar comp-subs) s)
 342               (incf total s)))
 343           ;; Take care of the "1.0" spec.
 344           (if rest
 345               (setcar (cdr rest) (- len total))
 346             (error "No 1.0 specs in %s" split))
 347           ;; The we do the actual splitting in a nice recursive
 348           ;; fashion.
 349           (setq comp-subs (nreverse comp-subs))
 350           (while comp-subs
 351             (if (null (cdr comp-subs))
 352                 (setq new-win window)
 353               (setq new-win
 354                     (split-window window (cadar comp-subs)
 355                                   (eq type 'horizontal))))
 356             (setq result (or (gnus-configure-frame
 357                               (car comp-subs) window)
 358                              result))
 359             (select-window new-win)
 360             (setq window new-win)
 361             (setq comp-subs (cdr comp-subs))))
 362         ;; Return the proper window, if any.
 363         (when result
 364           (select-window result)))))))
 365
 366 (defvar gnus-frame-split-p nil)
 367
 368 (defun gnus-configure-windows (setting &optional force)
 369   (if (window-configuration-p setting)
 370       (set-window-configuration setting)
 371     (setq gnus-current-window-configuration setting)
 372     (setq force (or force gnus-always-force-window-configuration))
 373     (let ((split (if (symbolp setting)
 374                      (cadr (assq setting gnus-buffer-configuration))
 375                    setting))
 376           all-visible)
 377
 378       (setq gnus-frame-split-p nil)
 379
 380       (unless split
 381         (error "No such setting in `gnus-buffer-configuration': %s" setting))
 382
 383       (if (and (setq all-visible (gnus-all-windows-visible-p split))
 384                (not force))
 385           ;; All the windows mentioned are already visible, so we just
 386           ;; put point in the assigned buffer, and do not touch the
 387           ;; winconf.
 388           (select-window all-visible)
 389
 390         ;; Make sure "the other" buffer, nntp-server-buffer, is live.
 391         (unless (gnus-buffer-live-p nntp-server-buffer)
 392           (nnheader-init-server-buffer))
 393
 394         ;; Either remove all windows or just remove all Gnus windows.
 395         (let ((frame (selected-frame)))
 396           (unwind-protect
 397               (if gnus-use-full-window
 398                   ;; We want to remove all other windows.
 399                   (if (not gnus-frame-split-p)
 400                       ;; This is not a `frame' split, so we ignore the
 401                       ;; other frames.
 402                       (delete-other-windows)
 403                     ;; This is a `frame' split, so we delete all windows
 404                     ;; on all frames.
 405                     (gnus-delete-windows-in-gnusey-frames))
 406                 ;; Just remove some windows.
 407                 (gnus-remove-some-windows)
 408                 (if (featurep 'xemacs)
 409                     (switch-to-buffer nntp-server-buffer)
 410                   (set-buffer nntp-server-buffer)))
 411             (select-frame frame)))
 412
 413         (let (gnus-window-frame-focus)
 414           (if (featurep 'xemacs)
 415               (switch-to-buffer nntp-server-buffer)
 416             (set-buffer nntp-server-buffer))
 417           (gnus-configure-frame split)
 418           (run-hooks 'gnus-configure-windows-hook)
 419           (when gnus-window-frame-focus
 420             (gnus-select-frame-set-input-focus
 421              (window-frame gnus-window-frame-focus))))))))
 422
 423 (defun gnus-delete-windows-in-gnusey-frames ()
 424   "Do a `delete-other-windows' in all frames that have Gnus windows."
 425   (let ((buffers (gnus-buffers)))
 426     (mapcar
 427      (lambda (frame)
 428        (unless (eq (cdr (assq 'minibuffer
 429                               (frame-parameters frame)))
 430                    'only)
 431          (select-frame frame)
 432          (let (do-delete)
 433            (walk-windows
 434             (lambda (window)
 435               (when (memq (window-buffer window) buffers)
 436                 (setq do-delete t))))
 437            (when do-delete
 438              (delete-other-windows)))))
 439      (frame-list))))
 440
 441 (defun gnus-all-windows-visible-p (split)
 442   "Say whether all buffers in SPLIT are currently visible.
 443 In particular, the value returned will be the window that
 444 should have point."
 445   (let ((stack (list split))
 446         (all-visible t)
 447         type buffer win buf)
 448     (while (and (setq split (pop stack))
 449                 all-visible)
 450       ;; Be backwards compatible.
 451       (when (vectorp split)
 452         (setq split (append split nil)))
 453       (when (or (consp (car split))
 454                 (vectorp (car split)))
 455         (push 1.0 split)
 456         (push 'vertical split))
 457       ;; The SPLIT might be something that is to be evaled to
 458       ;; return a new SPLIT.
 459       (while (and (not (assq (car split) gnus-window-to-buffer))
 460                   (symbolp (car split)) (fboundp (car split)))
 461         (setq split (eval split)))
 462
 463       (setq type (elt split 0))
 464       (cond
 465        ;; Nothing here.
 466        ((null split) t)
 467        ;; A buffer.
 468        ((not (memq type '(horizontal vertical frame)))
 469         (setq buffer (cond ((stringp type) type)
 470                            (t (cdr (assq type gnus-window-to-buffer)))))
 471         (unless buffer
 472           (error "Invalid buffer type: %s" type))
 473         (if (and (setq buf (get-buffer (gnus-window-to-buffer-helper buffer)))
 474                  (setq win (gnus-get-buffer-window buf t)))
 475             (if (memq 'point split)
 476                 (setq all-visible win))
 477           (setq all-visible nil)))
 478        (t
 479         (when (eq type 'frame)
 480           (setq gnus-frame-split-p t))
 481         (setq stack (append (cddr split) stack)))))
 482     (unless (eq all-visible t)
 483       all-visible)))
 484
 485 (defun gnus-window-top-edge (&optional window)
 486   (nth 1 (window-edges window)))
 487
 488 (defun gnus-remove-some-windows ()
 489   (let ((buffers (gnus-buffers))
 490         buf bufs lowest-buf lowest)
 491     (save-excursion
 492       ;; Remove windows on all known Gnus buffers.
 493       (while (setq buf (pop buffers))
 494         (when (get-buffer-window buf)
 495           (push buf bufs)
 496           (pop-to-buffer buf)
 497           (when (or (not lowest)
 498                     (< (gnus-window-top-edge) lowest))
 499             (setq lowest (gnus-window-top-edge)
 500                   lowest-buf buf))))
 501       (when lowest-buf
 502         (pop-to-buffer lowest-buf)
 503         (if (featurep 'xemacs)
 504             (switch-to-buffer nntp-server-buffer)
 505           (set-buffer nntp-server-buffer)))
 506       (mapcar (lambda (b) (delete-windows-on b t))
 507               (delq lowest-buf bufs)))))
 508
 509 (eval-and-compile
 510   (cond
 511    ((fboundp 'frames-on-display-list)
 512     (defalias 'gnus-frames-on-display-list 'frames-on-display-list))
 513    ((and (featurep 'xemacs) (fboundp 'frame-device))
 514     (defun gnus-frames-on-display-list ()
 515       (apply 'filtered-frame-list 'identity (list (frame-device nil)))))
 516    (t
 517     (defalias 'gnus-frames-on-display-list 'frame-list))))
 518
 519 (defun gnus-get-buffer-window (buffer &optional frame)
 520   (cond ((and (null gnus-use-frames-on-any-display)
 521               (memq frame '(t 0 visible)))
 522          (car
 523           (let ((frames (gnus-frames-on-display-list)))
 524             (gnus-remove-if (lambda (win) (not (memq (window-frame win)
 525                                                      frames)))
 526                             (get-buffer-window-list buffer nil frame)))))
 527         (t
 528          (get-buffer-window buffer frame))))
 529
 530 (provide 'gnus-win)
 531
 532 ;;; gnus-win.el ends here