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 ((window (or window (get-buffer-window (current-buffer)) (selected-window))))
 253     (select-window window)
 254     ;; The SPLIT might be something that is to be evaled to
 255     ;; return a new SPLIT.
 256     (while (and (not (assq (car split) gnus-window-to-buffer))
 257                 (symbolp (car split)) (fboundp (car split)))
 258       (setq split (eval split)))
 259     (let* ((type (car split))
 260            (subs (cddr split))
 261            (len (if (eq type 'horizontal) (window-width) (window-height)))
 262            (total 0)
 263            (window-min-width (or gnus-window-min-width window-min-width))
 264            (window-min-height (or gnus-window-min-height window-min-height))
 265            s result new-win rest comp-subs size sub)
 266       (cond
 267        ;; Nothing to do here.
 268        ((null split))
 269        ;; Don't switch buffers.
 270        ((null type)
 271         (and (memq 'point split) window))
 272        ;; This is a buffer to be selected.
 273        ((not (memq type '(frame horizontal vertical)))
 274         (let ((buffer (cond ((stringp type) type)
 275                             (t (cdr (assq type gnus-window-to-buffer))))))
 276           (unless buffer
 277             (error "Invalid buffer type: %s" type))
 278           (let ((buf (gnus-get-buffer-create
 279                       (gnus-window-to-buffer-helper buffer))))
 280             (if (eq buf (window-buffer (selected-window))) (set-buffer buf)
 281               (switch-to-buffer buf)))
 282           (when (memq 'frame-focus split)
 283             (setq gnus-window-frame-focus window))
 284           ;; We return the window if it has the `point' spec.
 285           (and (memq 'point split) window)))
 286        ;; This is a frame split.
 287        ((eq type 'frame)
 288         (unless gnus-frame-list
 289           (setq gnus-frame-list (list (window-frame current-window))))
 290         (let ((i 0)
 291               params frame fresult)
 292           (while (< i (length subs))
 293             ;; Frame parameter is gotten from the sub-split.
 294             (setq params (cadr (elt subs i)))
 295             ;; It should be a list.
 296             (unless (listp params)
 297               (setq params nil))
 298             ;; Create a new frame?
 299             (unless (setq frame (elt gnus-frame-list i))
 300               (nconc gnus-frame-list (list (setq frame (make-frame params))))
 301               (push frame gnus-created-frames))
 302             ;; Is the old frame still alive?
 303             (unless (frame-live-p frame)
 304               (setcar (nthcdr i gnus-frame-list)
 305                       (setq frame (make-frame params))))
 306             ;; Select the frame in question and do more splits there.
 307             (select-frame frame)
 308             (setq fresult (or (gnus-configure-frame (elt subs i)) fresult))
 309             (incf i))
 310           ;; Select the frame that has the selected buffer.
 311           (when fresult
 312             (select-frame (window-frame fresult)))))
 313        ;; This is a normal split.
 314        (t
 315         (when (> (length subs) 0)
 316           ;; First we have to compute the sizes of all new windows.
 317           (while subs
 318             (setq sub (append (pop subs) nil))
 319             (while (and (not (assq (car sub) gnus-window-to-buffer))
 320                         (symbolp (car sub)) (fboundp (car sub)))
 321               (setq sub (eval sub)))
 322             (when sub
 323               (push sub comp-subs)
 324               (setq size (cadar comp-subs))
 325               (cond ((equal size 1.0)
 326                      (setq rest (car comp-subs))
 327                      (setq s 0))
 328                     ((floatp size)
 329                      (setq s (floor (* size len))))
 330                     ((integerp size)
 331                      (setq s size))
 332                     (t
 333                      (error "Invalid size: %s" size)))
 334               ;; Try to make sure that we are inside the safe limits.
 335               (cond ((zerop s))
 336                     ((eq type 'horizontal)
 337                      (setq s (max s window-min-width)))
 338                     ((eq type 'vertical)
 339                      (setq s (max s window-min-height))))
 340               (setcar (cdar comp-subs) s)
 341               (incf total s)))
 342           ;; Take care of the "1.0" spec.
 343           (if rest
 344               (setcar (cdr rest) (- len total))
 345             (error "No 1.0 specs in %s" split))
 346           ;; The we do the actual splitting in a nice recursive
 347           ;; fashion.
 348           (setq comp-subs (nreverse comp-subs))
 349           (while comp-subs
 350             (if (null (cdr comp-subs))
 351                 (setq new-win window)
 352               (setq new-win
 353                     (split-window window (cadar comp-subs)
 354                                   (eq type 'horizontal))))
 355             (setq result (or (gnus-configure-frame
 356                               (car comp-subs) window)
 357                              result))
 358             (select-window new-win)
 359             (setq window new-win)
 360             (setq comp-subs (cdr comp-subs))))
 361         ;; Return the proper window, if any.
 362         (when result
 363           (select-window result)))))))
 364
 365 (defvar gnus-frame-split-p nil)
 366
 367 (defun gnus-configure-windows (setting &optional force)
 368   (if (window-configuration-p setting)
 369       (set-window-configuration setting)
 370     (setq gnus-current-window-configuration setting)
 371     (setq force (or force gnus-always-force-window-configuration))
 372     (let ((split (if (symbolp setting)
 373                      (cadr (assq setting gnus-buffer-configuration))
 374                    setting))
 375           all-visible)
 376
 377       (setq gnus-frame-split-p nil)
 378
 379       (unless split
 380         (error "No such setting in `gnus-buffer-configuration': %s" setting))
 381
 382       (if (and (setq all-visible (gnus-all-windows-visible-p split))
 383                (not force))
 384           ;; All the windows mentioned are already visible, so we just
 385           ;; put point in the assigned buffer, and do not touch the
 386           ;; winconf.
 387           (select-window all-visible)
 388
 389         ;; Make sure "the other" buffer, nntp-server-buffer, is live.
 390         (unless (gnus-buffer-live-p nntp-server-buffer)
 391           (nnheader-init-server-buffer))
 392
 393         ;; Either remove all windows or just remove all Gnus windows.
 394         (let ((frame (selected-frame)))
 395           (unwind-protect
 396               (if gnus-use-full-window
 397                   ;; We want to remove all other windows.
 398                   (if (not gnus-frame-split-p)
 399                       ;; This is not a `frame' split, so we ignore the
 400                       ;; other frames.
 401                       (delete-other-windows)
 402                     ;; This is a `frame' split, so we delete all windows
 403                     ;; on all frames.
 404                     (gnus-delete-windows-in-gnusey-frames))
 405                 ;; Just remove some windows.
 406                 (gnus-remove-some-windows)
 407                 (if (featurep 'xemacs)
 408                     (switch-to-buffer nntp-server-buffer)
 409                   (set-buffer nntp-server-buffer)))
 410             (select-frame frame)))
 411
 412         (let (gnus-window-frame-focus)
 413           (if (featurep 'xemacs)
 414               (switch-to-buffer nntp-server-buffer)
 415             (set-buffer nntp-server-buffer))
 416           (gnus-configure-frame split)
 417           (run-hooks 'gnus-configure-windows-hook)
 418           (when gnus-window-frame-focus
 419             (gnus-select-frame-set-input-focus
 420              (window-frame gnus-window-frame-focus))))))))
 421
 422 (defun gnus-delete-windows-in-gnusey-frames ()
 423   "Do a `delete-other-windows' in all frames that have Gnus windows."
 424   (let ((buffers (gnus-buffers)))
 425     (mapcar
 426      (lambda (frame)
 427        (unless (eq (cdr (assq 'minibuffer
 428                               (frame-parameters frame)))
 429                    'only)
 430          (select-frame frame)
 431          (let (do-delete)
 432            (walk-windows
 433             (lambda (window)
 434               (when (memq (window-buffer window) buffers)
 435                 (setq do-delete t))))
 436            (when do-delete
 437              (delete-other-windows)))))
 438      (frame-list))))
 439
 440 (defun gnus-all-windows-visible-p (split)
 441   "Say whether all buffers in SPLIT are currently visible.
 442 In particular, the value returned will be the window that
 443 should have point."
 444   (let ((stack (list split))
 445         (all-visible t)
 446         type buffer win buf)
 447     (while (and (setq split (pop stack))
 448                 all-visible)
 449       ;; Be backwards compatible.
 450       (when (vectorp split)
 451         (setq split (append split nil)))
 452       (when (or (consp (car split))
 453                 (vectorp (car split)))
 454         (push 1.0 split)
 455         (push 'vertical split))
 456       ;; The SPLIT might be something that is to be evaled to
 457       ;; return a new SPLIT.
 458       (while (and (not (assq (car split) gnus-window-to-buffer))
 459                   (symbolp (car split)) (fboundp (car split)))
 460         (setq split (eval split)))
 461
 462       (setq type (elt split 0))
 463       (cond
 464        ;; Nothing here.
 465        ((null split) t)
 466        ;; A buffer.
 467        ((not (memq type '(horizontal vertical frame)))
 468         (setq buffer (cond ((stringp type) type)
 469                            (t (cdr (assq type gnus-window-to-buffer)))))
 470         (unless buffer
 471           (error "Invalid buffer type: %s" type))
 472         (if (and (setq buf (get-buffer (gnus-window-to-buffer-helper buffer)))
 473                  (setq win (gnus-get-buffer-window buf t)))
 474             (if (memq 'point split)
 475                 (setq all-visible win))
 476           (setq all-visible nil)))
 477        (t
 478         (when (eq type 'frame)
 479           (setq gnus-frame-split-p t))
 480         (setq stack (append (cddr split) stack)))))
 481     (unless (eq all-visible t)
 482       all-visible)))
 483
 484 (defun gnus-window-top-edge (&optional window)
 485   (nth 1 (window-edges window)))
 486
 487 (defun gnus-remove-some-windows ()
 488   (let ((buffers (gnus-buffers))
 489         buf bufs lowest-buf lowest)
 490     (save-excursion
 491       ;; Remove windows on all known Gnus buffers.
 492       (while (setq buf (pop buffers))
 493         (when (get-buffer-window buf)
 494           (push buf bufs)
 495           (pop-to-buffer buf)
 496           (when (or (not lowest)
 497                     (< (gnus-window-top-edge) lowest))
 498             (setq lowest (gnus-window-top-edge)
 499                   lowest-buf buf))))
 500       (when lowest-buf
 501         (pop-to-buffer lowest-buf)
 502         (if (featurep 'xemacs)
 503             (switch-to-buffer nntp-server-buffer)
 504           (set-buffer nntp-server-buffer)))
 505       (mapcar (lambda (b) (delete-windows-on b t))
 506               (delq lowest-buf bufs)))))
 507
 508 (eval-and-compile
 509   (cond
 510    ((fboundp 'frames-on-display-list)
 511     (defalias 'gnus-frames-on-display-list 'frames-on-display-list))
 512    ((and (featurep 'xemacs) (fboundp 'frame-device))
 513     (defun gnus-frames-on-display-list ()
 514       (apply 'filtered-frame-list 'identity (list (frame-device nil)))))
 515    (t
 516     (defalias 'gnus-frames-on-display-list 'frame-list))))
 517
 518 (defun gnus-get-buffer-window (buffer &optional frame)
 519   (cond ((and (null gnus-use-frames-on-any-display)
 520               (memq frame '(t 0 visible)))
 521          (car
 522           (let ((frames (gnus-frames-on-display-list)))
 523             (gnus-remove-if (lambda (win) (not (memq (window-frame win)
 524                                                      frames)))
 525                             (get-buffer-window-list buffer nil frame)))))
 526         (t
 527          (get-buffer-window buffer frame))))
 528
 529 (provide 'gnus-win)
 530
 531 ;;; gnus-win.el ends here