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

   1 ;;; gnus-win.el --- window configuration functions for Gnus
   2
   3 ;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (eval-when-compile (require 'cl))
  28
  29 (require 'gnus)
  30 (require 'gnus-util)
  31
  32 (defgroup gnus-windows nil
  33   "Window configuration."
  34   :group 'gnus)
  35
  36 (defcustom gnus-use-full-window t
  37   "*If non-nil, use the entire Emacs screen."
  38   :group 'gnus-windows
  39   :type 'boolean)
  40
  41 (defvar gnus-window-configuration nil
  42   "Obsolete variable.  See `gnus-buffer-configuration'.")
  43
  44 (defcustom gnus-window-min-width 2
  45   "*Minimum width of Gnus buffers."
  46   :group 'gnus-windows
  47   :type 'integer)
  48
  49 (defcustom gnus-window-min-height 1
  50   "*Minimum height of Gnus buffers."
  51   :group 'gnus-windows
  52   :type 'integer)
  53
  54 (defcustom gnus-always-force-window-configuration nil
  55   "*If non-nil, always force the Gnus window configurations."
  56   :group 'gnus-windows
  57   :type 'boolean)
  58
  59 (defcustom gnus-use-frames-on-any-display nil
  60   "*If non-nil, frames on all displays will be considered useable by Gnus.
  61 When nil, only frames on the same display as the selected frame will be
  62 used to display Gnus windows."
  63   :version "22.1"
  64   :group 'gnus-windows
  65   :type 'boolean)
  66
  67 (defvar gnus-buffer-configuration
  68   '((group
  69      (vertical 1.0
  70                (group 1.0 point)))
  71     (summary
  72      (vertical 1.0
  73                (summary 1.0 point)))
  74     (article
  75      (cond
  76       (gnus-use-trees
  77        '(vertical 1.0
  78                   (summary 0.25 point)
  79                   (tree 0.25)
  80                   (article 1.0)))
  81       (t
  82        '(vertical 1.0
  83                   (summary 0.25 point)
  84                   (article 1.0)))))
  85     (server
  86      (vertical 1.0
  87                (server 1.0 point)))
  88     (browse
  89      (vertical 1.0
  90                (browse 1.0 point)))
  91     (message
  92      (vertical 1.0
  93                (message 1.0 point)))
  94     (pick
  95      (vertical 1.0
  96                (article 1.0 point)))
  97     (info
  98      (vertical 1.0
  99                (info 1.0 point)))
 100     (summary-faq
 101      (vertical 1.0
 102                (summary 0.25)
 103                (faq 1.0 point)))
 104     (only-article
 105      (vertical 1.0
 106                (article 1.0 point)))
 107     (edit-article
 108      (vertical 1.0
 109                (article 1.0 point)))
 110     (edit-form
 111      (vertical 1.0
 112                (group 0.5)
 113                (edit-form 1.0 point)))
 114     (edit-score
 115      (vertical 1.0
 116                (summary 0.25)
 117                (edit-score 1.0 point)))
 118     (edit-server
 119      (vertical 1.0
 120                (server 0.5)
 121                (edit-form 1.0 point)))
 122     (post
 123      (vertical 1.0
 124                (post 1.0 point)))
 125     (reply
 126      (vertical 1.0
 127                (article 0.5)
 128                (message 1.0 point)))
 129     (forward
 130      (vertical 1.0
 131                (message 1.0 point)))
 132     (reply-yank
 133      (vertical 1.0
 134                (message 1.0 point)))
 135     (mail-bounce
 136      (vertical 1.0
 137                (article 0.5)
 138                (message 1.0 point)))
 139     (pipe
 140      (vertical 1.0
 141                (summary 0.25 point)
 142                ("*Shell Command Output*" 1.0)))
 143     (bug
 144      (vertical 1.0
 145                (if gnus-bug-create-help-buffer '("*Gnus Help Bug*" 0.5))
 146                ("*Gnus Bug*" 1.0 point)))
 147     (score-trace
 148      (vertical 1.0
 149                (summary 0.5 point)
 150                ("*Score Trace*" 1.0)))
 151     (score-words
 152      (vertical 1.0
 153                (summary 0.5 point)
 154                ("*Score Words*" 1.0)))
 155     (split-trace
 156      (vertical 1.0
 157                (summary 0.5 point)
 158                ("*Split Trace*" 1.0)))
 159     (category
 160      (vertical 1.0
 161                (category 1.0)))
 162     (compose-bounce
 163      (vertical 1.0
 164                (article 0.5)
 165                (message 1.0 point)))
 166     (display-term
 167      (vertical 1.0
 168                ("*display*" 1.0)))
 169     (mml-preview
 170      (vertical 1.0
 171                (message 0.5)
 172                (mml-preview 1.0 point))))
 173   "Window configuration for all possible Gnus buffers.
 174 See the Gnus manual for an explanation of the syntax used.")
 175
 176 (defvar gnus-window-to-buffer
 177   '((group . gnus-group-buffer)
 178     (summary . gnus-summary-buffer)
 179     (article . gnus-article-buffer)
 180     (server . gnus-server-buffer)
 181     (browse . "*Gnus Browse Server*")
 182     (edit-group . gnus-group-edit-buffer)
 183     (edit-form . gnus-edit-form-buffer)
 184     (edit-server . gnus-server-edit-buffer)
 185     (edit-score . gnus-score-edit-buffer)
 186     (message . gnus-message-buffer)
 187     (mail . gnus-message-buffer)
 188     (post-news . gnus-message-buffer)
 189     (faq . gnus-faq-buffer)
 190     (tree . gnus-tree-buffer)
 191     (score-trace . "*Score Trace*")
 192     (split-trace . "*Split Trace*")
 193     (info . gnus-info-buffer)
 194     (category . gnus-category-buffer)
 195     (article-copy . gnus-article-copy)
 196     (draft . gnus-draft-buffer)
 197     (mml-preview . mml-preview-buffer))
 198   "Mapping from short symbols to buffer names or buffer variables.")
 199
 200 (defcustom gnus-configure-windows-hook nil
 201   "*A hook called when configuring windows."
 202   :version "22.1"
 203   :group 'gnus-windows
 204   :type 'hook)
 205
 206 ;;; Internal variables.
 207
 208 (defvar gnus-current-window-configuration nil
 209   "The most recently set window configuration.")
 210
 211 (defvar gnus-created-frames nil)
 212 (defvar gnus-window-frame-focus nil)
 213
 214 (defun gnus-kill-gnus-frames ()
 215   "Kill all frames Gnus has created."
 216   (while gnus-created-frames
 217     (when (frame-live-p (car gnus-created-frames))
 218       ;; We slap a condition-case around this `delete-frame' to ensure
 219       ;; against errors if we try do delete the single frame that's left.
 220       (ignore-errors
 221         (delete-frame (car gnus-created-frames))))
 222     (pop gnus-created-frames)))
 223
 224 (defun gnus-window-configuration-element (list)
 225   (while (and list
 226               (not (assq (car list) gnus-window-configuration)))
 227     (pop list))
 228   (cadr (assq (car list) gnus-window-configuration)))
 229
 230 ;;;###autoload
 231 (defun gnus-add-configuration (conf)
 232   "Add the window configuration CONF to `gnus-buffer-configuration'."
 233   (setq gnus-buffer-configuration
 234         (cons conf (delq (assq (car conf) gnus-buffer-configuration)
 235                          gnus-buffer-configuration))))
 236
 237 (defvar gnus-frame-list nil)
 238
 239 (defun gnus-window-to-buffer-helper (obj)
 240   (cond ((not (symbolp obj))
 241          obj)
 242         ((boundp obj)
 243          (symbol-value obj))
 244         ((fboundp obj)
 245          (funcall obj))
 246         (t
 247          nil)))
 248
 249 (defun gnus-configure-frame (split &optional window)
 250   "Split WINDOW according to SPLIT."
 251   (let* ((current-window (or (get-buffer-window (current-buffer)) (selected-window)))
 252          (window (or window current-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