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