lisp/gnus/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                (if gnus-carpal '(group-carpal 4))))
  73     (summary
  74      (vertical 1.0
  75                (summary 1.0 point)
  76                (if gnus-carpal '(summary-carpal 4))))
  77     (article
  78      (cond
  79       (gnus-use-trees
  80        '(vertical 1.0
  81                   (summary 0.25 point)
  82                   (tree 0.25)
  83                   (article 1.0)))
  84       (t
  85        '(vertical 1.0
  86                   (summary 0.25 point)
  87                   (if gnus-carpal '(summary-carpal 4))
  88                   (article 1.0)))))
  89     (server
  90      (vertical 1.0
  91                (server 1.0 point)
  92                (if gnus-carpal '(server-carpal 2))))
  93     (browse
  94      (vertical 1.0
  95                (browse 1.0 point)
  96                (if gnus-carpal '(browse-carpal 2))))
  97     (message
  98      (vertical 1.0
  99                (message 1.0 point)))
 100     (pick
 101      (vertical 1.0
 102                (article 1.0 point)))
 103     (info
 104      (vertical 1.0
 105                (info 1.0 point)))
 106     (summary-faq
 107      (vertical 1.0
 108                (summary 0.25)
 109                (faq 1.0 point)))
 110     (edit-article
 111      (vertical 1.0
 112                (article 1.0 point)))
 113     (edit-form
 114      (vertical 1.0
 115                (group 0.5)
 116                (edit-form 1.0 point)))
 117     (edit-score
 118      (vertical 1.0
 119                (summary 0.25)
 120                (edit-score 1.0 point)))
 121     (edit-server
 122      (vertical 1.0
 123                (server 0.5)
 124                (edit-form 1.0 point)))
 125     (post
 126      (vertical 1.0
 127                (post 1.0 point)))
 128     (reply
 129      (vertical 1.0
 130                (article 0.5)
 131                (message 1.0 point)))
 132     (forward
 133      (vertical 1.0
 134                (message 1.0 point)))
 135     (reply-yank
 136      (vertical 1.0
 137                (message 1.0 point)))
 138     (mail-bounce
 139      (vertical 1.0
 140                (article 0.5)
 141                (message 1.0 point)))
 142     (pipe
 143      (vertical 1.0
 144                (summary 0.25 point)
 145                (if gnus-carpal '(summary-carpal 4))
 146                ("*Shell Command Output*" 1.0)))
 147     (bug
 148      (vertical 1.0
 149                (if gnus-bug-create-help-buffer '("*Gnus Help Bug*" 0.5))
 150                ("*Gnus Bug*" 1.0 point)))
 151     (score-trace
 152      (vertical 1.0
 153                (summary 0.5 point)
 154                ("*Score Trace*" 1.0)))
 155     (score-words
 156      (vertical 1.0
 157                (summary 0.5 point)
 158                ("*Score Words*" 1.0)))
 159     (split-trace
 160      (vertical 1.0
 161                (summary 0.5 point)
 162                ("*Split Trace*" 1.0)))
 163     (category
 164      (vertical 1.0
 165                (category 1.0)))
 166     (compose-bounce
 167      (vertical 1.0
 168                (article 0.5)
 169                (message 1.0 point)))
 170     (display-term
 171      (vertical 1.0
 172                ("*display*" 1.0)))
 173     (mml-preview
 174      (vertical 1.0
 175                (message 0.5)
 176                (mml-preview 1.0 point))))
 177   "Window configuration for all possible Gnus buffers.
 178 See the Gnus manual for an explanation of the syntax used.")
 179
 180 (defvar gnus-window-to-buffer
 181   '((group . gnus-group-buffer)
 182     (summary . gnus-summary-buffer)
 183     (article . gnus-article-buffer)
 184     (server . gnus-server-buffer)
 185     (browse . "*Gnus Browse Server*")
 186     (edit-group . gnus-group-edit-buffer)
 187     (edit-form . gnus-edit-form-buffer)
 188     (edit-server . gnus-server-edit-buffer)
 189     (group-carpal . gnus-carpal-group-buffer)
 190     (summary-carpal . gnus-carpal-summary-buffer)
 191     (server-carpal . gnus-carpal-server-buffer)
 192     (browse-carpal . gnus-carpal-browse-buffer)
 193     (edit-score . gnus-score-edit-buffer)
 194     (message . gnus-message-buffer)
 195     (mail . gnus-message-buffer)
 196     (post-news . gnus-message-buffer)
 197     (faq . gnus-faq-buffer)
 198     (tree . gnus-tree-buffer)
 199     (score-trace . "*Score Trace*")
 200     (split-trace . "*Split Trace*")
 201     (info . gnus-info-buffer)
 202     (category . gnus-category-buffer)
 203     (article-copy . gnus-article-copy)
 204     (draft . gnus-draft-buffer)
 205     (mml-preview . mml-preview-buffer))
 206   "Mapping from short symbols to buffer names or buffer variables.")
 207
 208 (defcustom gnus-configure-windows-hook nil
 209   "*A hook called when configuring windows."
 210   :version "22.1"
 211   :group 'gnus-windows
 212   :type 'hook)
 213
 214 ;;; Internal variables.
 215
 216 (defvar gnus-current-window-configuration nil
 217   "The most recently set window configuration.")
 218
 219 (defvar gnus-created-frames nil)
 220 (defvar gnus-window-frame-focus nil)
 221
 222 (defun gnus-kill-gnus-frames ()
 223   "Kill all frames Gnus has created."
 224   (while gnus-created-frames
 225     (when (frame-live-p (car gnus-created-frames))
 226       ;; We slap a condition-case around this `delete-frame' to ensure
 227       ;; against errors if we try do delete the single frame that's left.
 228       (ignore-errors
 229         (delete-frame (car gnus-created-frames))))
 230     (pop gnus-created-frames)))
 231
 232 (defun gnus-window-configuration-element (list)
 233   (while (and list
 234               (not (assq (car list) gnus-window-configuration)))
 235     (pop list))
 236   (cadr (assq (car list) gnus-window-configuration)))
 237
 238 (defun gnus-windows-old-to-new (setting)
 239   ;; First we take care of the really, really old Gnus 3 actions.
 240   (when (symbolp setting)
 241     (setq setting
 242           ;; Take care of ooold GNUS 3.x values.
 243           (cond ((eq setting 'SelectArticle) 'article)
 244                 ((memq setting '(SelectNewsgroup SelectSubject ExpandSubject))
 245                  'summary)
 246                 ((memq setting '(ExitNewsgroup)) 'group)
 247                 (t setting))))
 248   (if (or (listp setting)
 249           (not (and gnus-window-configuration
 250                     (memq setting '(group summary article)))))
 251       setting
 252     (let* ((elem
 253             (cond
 254              ((eq setting 'group)
 255               (gnus-window-configuration-element
 256                '(group newsgroups ExitNewsgroup)))
 257              ((eq setting 'summary)
 258               (gnus-window-configuration-element
 259                '(summary SelectNewsgroup SelectSubject ExpandSubject)))
 260              ((eq setting 'article)
 261               (gnus-window-configuration-element
 262                '(article SelectArticle)))))
 263            (total (apply '+ elem))
 264            (types '(group summary article))
 265            (pbuf (if (eq setting 'newsgroups) 'group 'summary))
 266            (i 0)
 267            perc out)
 268       (while (< i 3)
 269         (or (not (numberp (nth i elem)))
 270             (zerop (nth i elem))
 271             (progn
 272               (setq perc (if (= i 2)
 273                              1.0
 274                            (/ (float (nth i elem)) total)))
 275               (push (if (eq pbuf (nth i types))
 276                         (list (nth i types) perc 'point)
 277                       (list (nth i types) perc))
 278                     out)))
 279         (incf i))
 280       `(vertical 1.0 ,@(nreverse out)))))
 281
 282 ;;;###autoload
 283 (defun gnus-add-configuration (conf)
 284   "Add the window configuration CONF to `gnus-buffer-configuration'."
 285   (setq gnus-buffer-configuration
 286         (cons conf (delq (assq (car conf) gnus-buffer-configuration)
 287                          gnus-buffer-configuration))))
 288
 289 (defvar gnus-frame-list nil)
 290
 291 (defun gnus-window-to-buffer-helper (obj)
 292   (cond ((not (symbolp obj))
 293          obj)
 294         ((boundp obj)
 295          (symbol-value obj))
 296         ((fboundp obj)
 297          (funcall obj))
 298         (t
 299          nil)))
 300
 301 (defun gnus-configure-frame (split &optional window)
 302   "Split WINDOW according to SPLIT."
 303   (let ((current-window
 304          (or (get-buffer-window (current-buffer)) (selected-window))))
 305     (unless window
 306       (setq window current-window))
 307     (select-window window)
 308     ;; This might be an old-style buffer config.
 309     (when (vectorp split)
 310       (setq split (append split nil)))
 311     (when (or (consp (car split))
 312               (vectorp (car split)))
 313       (push 1.0 split)
 314       (push 'vertical split))
 315     ;; The SPLIT might be something that is to be evaled to
 316     ;; return a new SPLIT.
 317     (while (and (not (assq (car split) gnus-window-to-buffer))
 318                 (symbolp (car split)) (fboundp (car split)))
 319       (setq split (eval split)))
 320     (let* ((type (car split))
 321            (subs (cddr split))
 322            (len (if (eq type 'horizontal) (window-width) (window-height)))
 323            (total 0)
 324            (window-min-width (or gnus-window-min-width window-min-width))
 325            (window-min-height (or gnus-window-min-height window-min-height))
 326            s result new-win rest comp-subs size sub)
 327       (cond
 328        ;; Nothing to do here.
 329        ((null split))
 330        ;; Don't switch buffers.
 331        ((null type)
 332         (and (memq 'point split) window))
 333        ;; This is a buffer to be selected.
 334        ((not (memq type '(frame horizontal vertical)))
 335         (let ((buffer (cond ((stringp type) type)
 336                             (t (cdr (assq type gnus-window-to-buffer))))))
 337           (unless buffer
 338             (error "Invalid buffer type: %s" type))
 339           (let ((buf (gnus-get-buffer-create
 340                       (gnus-window-to-buffer-helper buffer))))
 341             (if (eq buf (window-buffer (selected-window))) (set-buffer buf)
 342               (switch-to-buffer buf)))
 343           (when (memq 'frame-focus split)
 344             (setq gnus-window-frame-focus window))
 345           ;; We return the window if it has the `point' spec.
 346           (and (memq 'point split) window)))
 347        ;; This is a frame split.
 348        ((eq type 'frame)
 349         (unless gnus-frame-list
 350           (setq gnus-frame-list (list (window-frame current-window))))
 351         (let ((i 0)
 352               params frame fresult)
 353           (while (< i (length subs))
 354             ;; Frame parameter is gotten from the sub-split.
 355             (setq params (cadr (elt subs i)))
 356             ;; It should be a list.
 357             (unless (listp params)
 358               (setq params nil))
 359             ;; Create a new frame?
 360             (unless (setq frame (elt gnus-frame-list i))
 361               (nconc gnus-frame-list (list (setq frame (make-frame params))))
 362               (push frame gnus-created-frames))
 363             ;; Is the old frame still alive?
 364             (unless (frame-live-p frame)
 365               (setcar (nthcdr i gnus-frame-list)
 366                       (setq frame (make-frame params))))
 367             ;; Select the frame in question and do more splits there.
 368             (select-frame frame)
 369             (setq fresult (or (gnus-configure-frame (elt subs i)) fresult))
 370             (incf i))
 371           ;; Select the frame that has the selected buffer.
 372           (when fresult
 373             (select-frame (window-frame fresult)))))
 374        ;; This is a normal split.
 375        (t
 376         (when (> (length subs) 0)
 377           ;; First we have to compute the sizes of all new windows.
 378           (while subs
 379             (setq sub (append (pop subs) nil))
 380             (while (and (not (assq (car sub) gnus-window-to-buffer))
 381                         (symbolp (car sub)) (fboundp (car sub)))
 382               (setq sub (eval sub)))
 383             (when sub
 384               (push sub comp-subs)
 385               (setq size (cadar comp-subs))
 386               (cond ((equal size 1.0)
 387                      (setq rest (car comp-subs))
 388                      (setq s 0))
 389                     ((floatp size)
 390                      (setq s (floor (* size len))))
 391                     ((integerp size)
 392                      (setq s size))
 393                     (t
 394                      (error "Invalid size: %s" size)))
 395               ;; Try to make sure that we are inside the safe limits.
 396               (cond ((zerop s))
 397                     ((eq type 'horizontal)
 398                      (setq s (max s window-min-width)))
 399                     ((eq type 'vertical)
 400                      (setq s (max s window-min-height))))
 401               (setcar (cdar comp-subs) s)
 402               (incf total s)))
 403           ;; Take care of the "1.0" spec.
 404           (if rest
 405               (setcar (cdr rest) (- len total))
 406             (error "No 1.0 specs in %s" split))
 407           ;; The we do the actual splitting in a nice recursive
 408           ;; fashion.
 409           (setq comp-subs (nreverse comp-subs))
 410           (while comp-subs
 411             (if (null (cdr comp-subs))
 412                 (setq new-win window)
 413               (setq new-win
 414                     (split-window window (cadar comp-subs)
 415                                   (eq type 'horizontal))))
 416             (setq result (or (gnus-configure-frame
 417                               (car comp-subs) window)
 418                              result))
 419             (select-window new-win)
 420             (setq window new-win)
 421             (setq comp-subs (cdr comp-subs))))
 422         ;; Return the proper window, if any.
 423         (when result
 424           (select-window result)))))))
 425
 426 (defvar gnus-frame-split-p nil)
 427
 428 (defun gnus-configure-windows (setting &optional force)
 429   (if (window-configuration-p setting)
 430       (set-window-configuration setting)
 431     (setq gnus-current-window-configuration setting)
 432     (setq force (or force gnus-always-force-window-configuration))
 433     (setq setting (gnus-windows-old-to-new setting))
 434     (let ((split (if (symbolp setting)
 435                      (cadr (assq setting gnus-buffer-configuration))
 436                    setting))
 437           all-visible)
 438
 439       (setq gnus-frame-split-p nil)
 440
 441       (unless split
 442         (error "No such setting in `gnus-buffer-configuration': %s" setting))
 443
 444       (if (and (setq all-visible (gnus-all-windows-visible-p split))
 445                (not force))
 446           ;; All the windows mentioned are already visible, so we just
 447           ;; put point in the assigned buffer, and do not touch the
 448           ;; winconf.
 449           (select-window all-visible)
 450
 451         ;; Make sure "the other" buffer, nntp-server-buffer, is live.
 452         (unless (gnus-buffer-live-p nntp-server-buffer)
 453           (nnheader-init-server-buffer))
 454
 455         ;; Either remove all windows or just remove all Gnus windows.
 456         (let ((frame (selected-frame)))
 457           (unwind-protect
 458               (if gnus-use-full-window
 459                   ;; We want to remove all other windows.
 460                   (if (not gnus-frame-split-p)
 461                       ;; This is not a `frame' split, so we ignore the
 462                       ;; other frames.
 463                       (delete-other-windows)
 464                   ;; This is a `frame' split, so we delete all windows
 465                     ;; on all frames.
 466                     (gnus-delete-windows-in-gnusey-frames))
 467                 ;; Just remove some windows.
 468                 (gnus-remove-some-windows)
 469                 (if (featurep 'xemacs)
 470                     (switch-to-buffer nntp-server-buffer)
 471                   (set-buffer nntp-server-buffer)))
 472             (select-frame frame)))
 473
 474         (let (gnus-window-frame-focus)
 475           (if (featurep 'xemacs)
 476               (switch-to-buffer nntp-server-buffer)
 477             (set-buffer nntp-server-buffer))
 478           (gnus-configure-frame split)
 479           (run-hooks 'gnus-configure-windows-hook)
 480           (when gnus-window-frame-focus
 481             (gnus-select-frame-set-input-focus
 482              (window-frame gnus-window-frame-focus))))))))
 483
 484 (defun gnus-delete-windows-in-gnusey-frames ()
 485   "Do a `delete-other-windows' in all frames that have Gnus windows."
 486   (let ((buffers (gnus-buffers)))
 487     (mapcar
 488      (lambda (frame)
 489        (unless (eq (cdr (assq 'minibuffer
 490                               (frame-parameters frame)))
 491                    'only)
 492          (select-frame frame)
 493          (let (do-delete)
 494            (walk-windows
 495             (lambda (window)
 496               (when (memq (window-buffer window) buffers)
 497                 (setq do-delete t))))
 498            (when do-delete
 499              (delete-other-windows)))))
 500      (frame-list))))
 501
 502 (defun gnus-all-windows-visible-p (split)
 503   "Say whether all buffers in SPLIT are currently visible.
 504 In particular, the value returned will be the window that
 505 should have point."
 506   (let ((stack (list split))
 507         (all-visible t)
 508         type buffer win buf)
 509     (while (and (setq split (pop stack))
 510                 all-visible)
 511       ;; Be backwards compatible.
 512       (when (vectorp split)
 513         (setq split (append split nil)))
 514       (when (or (consp (car split))
 515                 (vectorp (car split)))
 516         (push 1.0 split)
 517         (push 'vertical split))
 518       ;; The SPLIT might be something that is to be evaled to
 519       ;; return a new SPLIT.
 520       (while (and (not (assq (car split) gnus-window-to-buffer))
 521                   (symbolp (car split)) (fboundp (car split)))
 522         (setq split (eval split)))
 523
 524       (setq type (elt split 0))
 525       (cond
 526        ;; Nothing here.
 527        ((null split) t)
 528        ;; A buffer.
 529        ((not (memq type '(horizontal vertical frame)))
 530         (setq buffer (cond ((stringp type) type)
 531                            (t (cdr (assq type gnus-window-to-buffer)))))
 532         (unless buffer
 533           (error "Invalid buffer type: %s" type))
 534         (if (and (setq buf (get-buffer (gnus-window-to-buffer-helper buffer)))
 535                  (setq win (gnus-get-buffer-window buf t)))
 536             (if (memq 'point split)
 537                 (setq all-visible win))
 538           (setq all-visible nil)))
 539        (t
 540         (when (eq type 'frame)
 541           (setq gnus-frame-split-p t))
 542         (setq stack (append (cddr split) stack)))))
 543     (unless (eq all-visible t)
 544       all-visible)))
 545
 546 (defun gnus-window-top-edge (&optional window)
 547   (nth 1 (window-edges window)))
 548
 549 (defun gnus-remove-some-windows ()
 550   (let ((buffers (gnus-buffers))
 551         buf bufs lowest-buf lowest)
 552     (save-excursion
 553       ;; Remove windows on all known Gnus buffers.
 554       (while (setq buf (pop buffers))
 555         (when (get-buffer-window buf)
 556           (push buf bufs)
 557           (pop-to-buffer buf)
 558           (when (or (not lowest)
 559                     (< (gnus-window-top-edge) lowest))
 560             (setq lowest (gnus-window-top-edge)
 561                   lowest-buf buf))))
 562       (when lowest-buf
 563         (pop-to-buffer lowest-buf)
 564         (if (featurep 'xemacs)
 565             (switch-to-buffer nntp-server-buffer)
 566           (set-buffer nntp-server-buffer)))
 567       (mapcar (lambda (b) (delete-windows-on b t))
 568               (delq lowest-buf bufs)))))
 569
 570 (eval-and-compile
 571   (cond
 572    ((fboundp 'frames-on-display-list)
 573     (defalias 'gnus-frames-on-display-list 'frames-on-display-list))
 574    ((and (featurep 'xemacs) (fboundp 'frame-device))
 575     (defun gnus-frames-on-display-list ()
 576       (apply 'filtered-frame-list 'identity (list (frame-device nil)))))
 577    (t
 578     (defalias 'gnus-frames-on-display-list 'frame-list))))
 579
 580 (defun gnus-get-buffer-window (buffer &optional frame)
 581   (cond ((and (null gnus-use-frames-on-any-display)
 582               (memq frame '(t 0 visible)))
 583          (car
 584           (let ((frames (gnus-frames-on-display-list)))
 585             (gnus-remove-if (lambda (win) (not (memq (window-frame win)
 586                                                      frames)))
 587                             (get-buffer-window-list buffer nil frame)))))
 588         (t
 589          (get-buffer-window buffer frame))))
 590
 591 (provide 'gnus-win)
 592
 593 ;; arch-tag: ccd5a394-2ddf-4397-b8f8-6d80d3e46e2b
 594 ;;; gnus-win.el ends here