lisp/dframe.el

   1 ;;; dframe --- dedicate frame support modes
   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: Eric M. Ludlam <zappo@gnu.org>
   7 ;; Keywords: file, tags, tools
   8
   9 (defvar dframe-version "1.3"
  10   "The current version of the dedicated frame library.")
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software: you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation, either version 3 of the License, or
  17 ;; (at your option) any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  26
  27 ;;; Commentary:
  28 ;;
  29 ;; This code was developed and maintained as a part of speedbar since 1996.
  30 ;; It became its own support utility in Aug 2000.
  31 ;;
  32 ;; Dedicated frame mode is an Emacs independent library for supporting
  33 ;; a program/buffer combination that resides in a dedicated frame.
  34 ;; Support of this nature requires several complex interactions with the
  35 ;; user which this library will provide, including:
  36 ;;
  37 ;; * Creation of a frame.  Positioned relatively.
  38 ;;   Includes a frame cache for User position caching.
  39 ;; * Switching between frames.
  40 ;; * Timed activities using idle-timers
  41 ;; * Frame/buffer killing hooks
  42 ;; * Mouse-3 position relative menu
  43 ;; * Mouse motion, help-echo hacks
  44 ;; * Mouse clicking, double clicking, & XEmacs image clicking hack
  45 ;; * Mode line hacking
  46 ;; * Utilities for use in a program covering:
  47 ;;    o keymap massage for some actions
  48 ;;    o working with an associated buffer
  49 ;;    o shift-click
  50 ;;    o detaching a frame
  51 ;;    o focus-shifting & optional frame jumping
  52 ;;    o currently active frame.
  53 ;;    o message/y-or-n-p
  54 ;;    o mouse set point
  55 ;;
  56 ;; To Use:
  57 ;; 1) (require 'dframe)
  58 ;; 2) Variable Setup:
  59 ;;   -frame-parameters -- Frame parameters for Emacs.
  60 ;;   -frame-plist -- Frame parameters for XEmacs.
  61 ;;   -- Not on parameter lists: They can optionally include width
  62 ;;      and height.  If width or height is not included, then it will
  63 ;;      be provided to match the originating frame.  In general,
  64 ;;      turning off the menu bar, mode line, and minibuffer can
  65 ;;      provide a smaller window, or more display area.
  66 ;;   -track-mouse-flag -- mouse tracking on/off specific to your tool.
  67 ;;   -update-flag -- app toggle for timer use.  Init from
  68 ;;     `dframe-have-timer-flag'.  This is nil for terminals, since
  69 ;;     updating a frame in a terminal is not useful to the user.
  70 ;;   -key-map -- Your keymap.  Call `dframe-update-keymap' on it.
  71 ;;   -buffer, -frame, -cached-frame -- Variables used to track your
  72 ;;     applications buffer, frame, or frame cache (when hidden).  See
  73 ;;     `dframe-frame-mode' for details.
  74 ;;   -before-delete-hook, -before-popup-hook, -after-create-hook --
  75 ;;     Hooks to have called.  The `-after-create-hook' probably wants
  76 ;;     to call a function which calls `dframe-reposition-frame' in an
  77 ;;     appropriate manner.
  78 ;; 3) Function Setup:
  79 ;;   your-frame-mode -- function to toggle your app frame on and off.
  80 ;;     its tasks are:
  81 ;;       a) create a buffer
  82 ;;       b) Call `dframe-frame-mode'.  (See its doc)
  83 ;;       c) If successful (your -frame variable has a value), call
  84 ;;          timer setup if applicable.
  85 ;;   your-frame-reposition- -- Function to call from after-create-hook to
  86 ;;     reposition your frame with `dframe-repsoition-frame'.
  87 ;;   your-mode -- Set up the major mode of the buffer for your app.
  88 ;;     Set these variables: dframe-track-mouse-function,
  89 ;;                          dframe-help-echo-function,
  90 ;;                          dframe-mouse-click-function,
  91 ;;                          dframe-mouse-position-function.
  92 ;;   See speedbar's implementation of these functions.
  93 ;;    `speedbar-current-frame', `speedbar-get-focus', `speedbar-message',
  94 ;;    `speedbar-y-or-n-p', `speedbar-set-timer', `speedbar-click',
  95 ;;    `speedbar-position-cursor-on-line'
  96 ;; 4) Handling mouse clicks, and help text:
  97 ;;   dframe-track-mouse, dframe-help-echo-function --
  98 ;;    These variables need to be set to functions that display info
  99 ;;    based on the mouse's position.
 100 ;;   Text propert 'help-echo, set to `dframe-help-echo', which will
 101 ;;    call `dframe-help-echo-function'.
 102 ;;   Have a `-click' function, it can call `dframe-quick-mouse' for
 103 ;;    positioning.  If the variable `dframe-power-click' is non-nil,
 104 ;;    then `shift' was held down during the click.
 105
 106 ;;; Bugs
 107 ;;
 108 ;;  * The timer managers doesn't handle multiple different timeouts.
 109 ;;  * You can't specify continuous timeouts (as opposed to just idle timers.)
 110
 111 (defvar x-pointer-hand2)
 112 (defvar x-pointer-top-left-arrow)
 113
 114 ;;; Code:
 115 \f
 116 ;;; Compatibility functions
 117 ;;
 118 (defalias 'dframe-frame-parameter
 119   (if (fboundp 'frame-parameter) 'frame-parameter
 120     (lambda (frame parameter)
 121       "Return FRAME's PARAMETER value."
 122       (cdr (assoc parameter (frame-parameters frame))))))
 123
 124 \f
 125 ;;; Variables
 126 ;;
 127 (defgroup dframe nil
 128   "Faces used in dframe."
 129   :prefix "dframe-"
 130   :group 'dframe)
 131
 132 (defvar dframe-have-timer-flag (if (fboundp 'display-graphic-p)
 133                                    (display-graphic-p)
 134                                  window-system)
 135   "Non-nil means that timers are available for this Emacs.
 136 This is nil for terminals, since updating a frame in a terminal
 137 is not useful to the user.")
 138
 139 (defcustom dframe-update-speed
 140   (if (featurep 'xemacs) 2              ; 1 is too obrusive in XEmacs
 141     1)
 142   "Idle time in seconds needed before dframe will update itself.
 143 Updates occur to allow dframe to display directory information
 144 relevant to the buffer you are currently editing."
 145   :group 'dframe
 146   :type 'integer)
 147
 148 (defcustom dframe-activity-change-focus-flag nil
 149   "Non-nil means the selected frame will change based on activity.
 150 Thus, if a file is selected for edit, the buffer will appear in the
 151 selected frame and the focus will change to that frame."
 152   :group 'dframe
 153   :type 'boolean)
 154
 155 (defcustom dframe-after-select-attached-frame-hook nil
 156   "Hook run after dframe has selected the attached frame."
 157   :group 'dframe
 158   :type 'hook)
 159
 160 (defvar dframe-track-mouse-function nil
 161   "*A function to call when the mouse is moved in the given frame.
 162 Typically used to display info about the line under the mouse.")
 163 (make-variable-buffer-local 'dframe-track-mouse-function)
 164
 165 (defvar dframe-help-echo-function nil
 166   "*A function to call when help-echo is used in newer versions of Emacs.
 167 Typically used to display info about the line under the mouse.")
 168 (make-variable-buffer-local 'dframe-help-echo-function)
 169
 170 (defvar dframe-mouse-click-function nil
 171   "*A function to call when the mouse is clicked.
 172 Valid clicks are mouse 2, our double mouse 1.")
 173 (make-variable-buffer-local 'dframe-mouse-click-function)
 174
 175 (defvar dframe-mouse-position-function nil
 176   "*A function to call to position the cursor for a mouse click.")
 177 (make-variable-buffer-local 'dframe-mouse-position-function)
 178
 179 (defvar dframe-power-click nil
 180   "Never set this by hand.  Value is t when S-mouse activity occurs.")
 181
 182 (defvar dframe-timer nil
 183   "The dframe timer used for updating the buffer.")
 184 (make-variable-buffer-local 'dframe-timer)
 185
 186 (defvar dframe-attached-frame nil
 187   "The frame which started a frame mode.
 188 This is the frame from which all interesting activities will go
 189 for the mode using dframe.")
 190 (make-variable-buffer-local 'dframe-attached-frame)
 191
 192 (defvar dframe-controlled nil
 193   "Is this buffer controlled by a dedicated frame.
 194 Local to those buffers, as a function called that created it.")
 195 (make-variable-buffer-local 'dframe-controlled)
 196
 197 (defun dframe-update-keymap (map)
 198   "Update the keymap MAP for dframe default bindings."
 199   ;; Frame control
 200   (define-key map "q" 'dframe-close-frame)
 201   (define-key map "Q" 'delete-frame)
 202
 203   ;; Override switch to buffer to never hack our frame.
 204   (substitute-key-definition 'switch-to-buffer
 205                              'dframe-switch-buffer-attached-frame
 206                              map global-map)
 207
 208   (if (featurep 'xemacs)
 209       (progn
 210         ;; mouse bindings so we can manipulate the items on each line
 211         (define-key map 'button2 'dframe-click)
 212         (define-key map '(shift button2) 'dframe-power-click)
 213         ;; Info doc fix from Bob Weiner
 214         (if (featurep 'infodoc)
 215             nil
 216           (define-key map 'button3 'dframe-popup-kludge))
 217         )
 218
 219     ;; mouse bindings so we can manipulate the items on each line
 220     ;; (define-key map [down-mouse-1] 'dframe-double-click)
 221     (define-key map [follow-link] 'mouse-face)
 222     (define-key map [mouse-2] 'dframe-click)
 223     ;; This is the power click for new frames, or refreshing a cache
 224     (define-key map [S-mouse-2] 'dframe-power-click)
 225     ;; This adds a small unecessary visual effect
 226     ;;(define-key map [down-mouse-2] 'dframe-quick-mouse)
 227
 228     (define-key map [down-mouse-3] 'dframe-popup-kludge)
 229
 230     ;; This lets the user scroll as if we had a scrollbar... well maybe not
 231     (define-key map [mode-line mouse-2] 'dframe-mouse-hscroll)
 232     ;; another handy place users might click to get our menu.
 233     (define-key map [mode-line down-mouse-1]
 234       'dframe-popup-kludge)
 235
 236     ;; We can't switch buffers with the buffer mouse menu.  Lets hack it.
 237     (define-key map [C-down-mouse-1] 'dframe-hack-buffer-menu)
 238
 239     ;; Lastly, we want to track the mouse.  Play here
 240     (define-key map [mouse-movement] 'dframe-track-mouse)
 241     ))
 242
 243 (defun dframe-live-p (frame)
 244   "Return non-nil if FRAME is currently available."
 245   (and frame (frame-live-p frame) (frame-visible-p frame)))
 246
 247 (defun dframe-frame-mode (arg frame-var cache-var buffer-var frame-name
 248                               local-mode-fn
 249                               &optional
 250                               parameters
 251                               delete-hook popup-hook create-hook
 252                               )
 253   "Manage a frame for an application, enabling it when ARG is positive.
 254 FRAME-VAR is a variable used to cache the frame being used.
 255 This frame is either resurrected, hidden, killed, etc based on
 256 the value.
 257 CACHE-VAR is a variable used to cache a cached frame.
 258 BUFFER-VAR is a variable used to cache the buffer being used in dframe.
 259 This buffer will have `dframe-frame-mode' run on it.
 260 FRAME-NAME is the name of the frame to create.
 261 LOCAL-MODE-FN is the function used to call this one.
 262 PARAMETERS are frame parameters to apply to this dframe.
 263 DELETE-HOOK are hooks to run when deleting a frame.
 264 POPUP-HOOK are hooks to run before showing a frame.
 265 CREATE-HOOK are hooks to run after creating a frame."
 266   ;; toggle frame on and off.
 267   (if (not arg) (if (dframe-live-p (symbol-value frame-var))
 268                     (setq arg -1) (setq arg 1)))
 269   ;; Make sure the current buffer is set.
 270   (set-buffer (symbol-value buffer-var))
 271   ;; turn the frame off on neg number
 272   (if (and (numberp arg) (< arg 0))
 273       (progn
 274         (run-hooks 'delete-hook)
 275         (if (and (symbol-value frame-var)
 276                  (frame-live-p (symbol-value frame-var)))
 277             (progn
 278               (set cache-var (symbol-value frame-var))
 279               (make-frame-invisible (symbol-value frame-var))))
 280         (set frame-var nil))
 281     ;; Set this as our currently attached frame
 282     (setq dframe-attached-frame (selected-frame))
 283     (run-hooks 'popup-hook)
 284     ;; Updated the buffer passed in to contain all the hacks needed
 285     ;; to make it work well in a dedicated window.
 286     (with-current-buffer (symbol-value buffer-var)
 287       ;; Declare this buffer a dedicated frame
 288       (setq dframe-controlled local-mode-fn)
 289
 290       (if (featurep 'xemacs)
 291           (progn
 292             ;; Hack the XEmacs mouse-motion handler
 293             (set (make-local-variable 'mouse-motion-handler)
 294                  'dframe-track-mouse-xemacs)
 295             ;; Hack the double click handler
 296             (make-local-variable 'mouse-track-click-hook)
 297             (add-hook 'mouse-track-click-hook
 298                       (lambda (event count)
 299                         (if (/= (event-button event) 1)
 300                             nil         ; Do normal operations.
 301                           (cond ((eq count 1)
 302                                  (dframe-quick-mouse event))
 303                                 ((or (eq count 2)
 304                                      (eq count 3))
 305                                  (dframe-click event)
 306                                  (dframe-quick-mouse event)))
 307                           ;; Don't do normal operations.
 308                           t))))
 309         ;; Enable mouse tracking in emacs
 310         (if dframe-track-mouse-function
 311             (set (make-local-variable 'track-mouse) t))) ;this could be messy.
 312 ;;;;  DISABLED: This causes problems for users with multiple frames.
 313 ;;;;       ;; Set this up special just for the passed in buffer
 314 ;;;;       ;; Terminal minibuffer stuff does not require this.
 315 ;;;;       (if (and (or (assoc 'minibuffer parameters)
 316 ;;;;               ;; XEmacs plist is not an association list
 317 ;;;;               (member 'minibuffer parameters))
 318 ;;;;           window-system (not (eq window-system 'pc))
 319 ;;;;           (null default-minibuffer-frame))
 320 ;;;;      (progn
 321 ;;;;        (make-local-variable 'default-minibuffer-frame)
 322 ;;;;        (setq default-minibuffer-frame dframe-attached-frame))
 323 ;;;;    )
 324       ;; Override `temp-buffer-show-hook' so that help and such
 325       ;; put their stuff into a frame other than our own.
 326       ;; Correct use of `temp-buffer-show-function': Bob Weiner
 327       (if (and (boundp 'temp-buffer-show-hook)
 328                (boundp 'temp-buffer-show-function))
 329           (progn (make-local-variable 'temp-buffer-show-hook)
 330                  (setq temp-buffer-show-hook temp-buffer-show-function)))
 331       (make-local-variable 'temp-buffer-show-function)
 332       (setq temp-buffer-show-function 'dframe-temp-buffer-show-function)
 333       ;; If this buffer is killed, we must make sure that we destroy
 334       ;; the frame the dedicated window is in.
 335       (add-hook 'kill-buffer-hook `(lambda ()
 336                                      (let ((skilling (boundp 'skilling)))
 337                                        (if skilling
 338                                            nil
 339                                          (if dframe-controlled
 340                                              (progn
 341                                                (funcall dframe-controlled -1)
 342                                                (setq ,buffer-var nil)
 343                                                )))))
 344                 t t)
 345       )
 346     ;; Get the frame to work in
 347     (if (frame-live-p (symbol-value cache-var))
 348         (progn
 349           (set frame-var (symbol-value cache-var))
 350           (make-frame-visible (symbol-value frame-var))
 351           (select-frame (symbol-value frame-var))
 352           (set-window-dedicated-p (selected-window) nil)
 353           (if (not (eq (current-buffer) (symbol-value buffer-var)))
 354               (switch-to-buffer (symbol-value buffer-var)))
 355           (set-window-dedicated-p (selected-window) t)
 356           (raise-frame (symbol-value frame-var))
 357           )
 358       (if (frame-live-p (symbol-value frame-var))
 359           (raise-frame (symbol-value frame-var))
 360         (set frame-var
 361               (if (featurep 'xemacs)
 362                   ;; Only guess height if it is not specified.
 363                   (if (member 'height parameters)
 364                       (make-frame parameters)
 365                     (make-frame (nconc (list 'height
 366                                              (dframe-needed-height))
 367                                        parameters)))
 368                 (let* ((mh (dframe-frame-parameter dframe-attached-frame
 369                                                    'menu-bar-lines))
 370                        (paramsa
 371                         ;; Only add a guessed height if one is not specified
 372                         ;; in the input parameters.
 373                         (if (assoc 'height parameters)
 374                             parameters
 375                           (append
 376                            parameters
 377                            (list (cons 'height (+ (or mh 0) (frame-height)))))))
 378                        (params
 379                         ;; Only add a guessed width if one is not specified
 380                         ;; in the input parameters.
 381                         (if (assoc 'width parameters)
 382                             paramsa
 383                           (append
 384                            paramsa
 385                            (list (cons 'width (frame-width))))))
 386                        (frame
 387                         (if (not (eq window-system 'x))
 388                             (make-frame params)
 389                           (let ((x-pointer-shape x-pointer-top-left-arrow)
 390                                 (x-sensitive-text-pointer-shape
 391                                  x-pointer-hand2))
 392                             (make-frame params)))))
 393                   frame)))
 394         ;; Put the buffer into the frame
 395         (save-excursion
 396           (select-frame (symbol-value frame-var))
 397           (switch-to-buffer (symbol-value buffer-var))
 398           (set-window-dedicated-p (selected-window) t))
 399         ;; Run hooks (like reposition)
 400         (run-hooks 'create-hook)
 401         ;; Frame name
 402         (if (and (or (null window-system) (eq window-system 'pc))
 403                  (fboundp 'set-frame-name))
 404             (save-window-excursion
 405               (select-frame (symbol-value frame-var))
 406               (set-frame-name frame-name)))
 407         ;; On a terminal, raise the frame or the user will
 408         ;; be confused.
 409         (if (not window-system)
 410             (select-frame (symbol-value frame-var)))
 411         ))) )
 412
 413 (defun dframe-reposition-frame (new-frame parent-frame location)
 414   "Move NEW-FRAME to be relative to PARENT-FRAME.
 415 LOCATION can be one of 'random, 'left, 'right, 'left-right, or 'top-bottom."
 416   (if (featurep 'xemacs)
 417       (dframe-reposition-frame-xemacs new-frame parent-frame location)
 418     (dframe-reposition-frame-emacs new-frame parent-frame location)))
 419
 420 ;; Not defined in builds without X, but behind window-system test.
 421 (declare-function x-display-pixel-width "xfns.c" (&optional terminal))
 422 (declare-function x-display-pixel-height "xfns.c" (&optional terminal))
 423
 424 (defun dframe-reposition-frame-emacs (new-frame parent-frame location)
 425   "Move NEW-FRAME to be relative to PARENT-FRAME.
 426 LOCATION can be one of 'random, 'left-right, 'top-bottom, or
 427 a cons cell indicating a position of the form (LEFT . TOP)."
 428   ;; Position dframe.
 429   ;; Do no positioning if not on a windowing system,
 430   (unless (or (not window-system) (eq window-system 'pc))
 431     (let* ((pfx (dframe-frame-parameter parent-frame 'left))
 432            (pfy (dframe-frame-parameter parent-frame 'top))
 433            (pfw (frame-pixel-width parent-frame))
 434            (pfh (frame-pixel-height parent-frame))
 435            (nfw (frame-pixel-width new-frame))
 436            (nfh (frame-pixel-height new-frame))
 437            newleft newtop)
 438       ;; Rebuild pfx,pfy to be absolute positions.
 439       (setq pfx (if (not (consp pfx))
 440                     pfx
 441                   ;; If pfx is a list, that means we grow
 442                   ;; from a specific edge of the display.
 443                   ;; Convert that to the distance from the
 444                   ;; left side of the display.
 445                   (if (eq (car pfx) '-)
 446                       ;; A - means distance from the right edge
 447                       ;; of the display, or DW - pfx - framewidth
 448                       (- (x-display-pixel-width) (car (cdr pfx)) pfw)
 449                     (car (cdr pfx))))
 450             pfy (if (not (consp pfy))
 451                     pfy
 452                   ;; If pfy is a list, that means we grow
 453                   ;; from a specific edge of the display.
 454                   ;; Convert that to the distance from the
 455                   ;; left side of the display.
 456                   (if (eq (car pfy) '-)
 457                       ;; A - means distance from the right edge
 458                       ;; of the display, or DW - pfx - framewidth
 459                       (- (x-display-pixel-height) (car (cdr pfy)) pfh)
 460                     (car (cdr pfy)))))
 461       (cond ((eq location 'right)
 462              (setq newleft (+ pfx pfw 5)
 463                    newtop pfy))
 464             ((eq location 'left)
 465              (setq newleft (- pfx 10 nfw)
 466                    newtop pfy))
 467             ((eq location 'left-right)
 468              (setq newleft
 469                    ;; Decide which side to put it on.  200 is just a
 470                    ;; buffer for the left edge of the screen.  The
 471                    ;; extra 10 is just dressings for window
 472                    ;; decorations.
 473                    (let* ((left-guess (- pfx 10 nfw))
 474                           (right-guess (+ pfx pfw 5))
 475                           (left-margin left-guess)
 476                           (right-margin (- (x-display-pixel-width)
 477                                            right-guess 5 nfw)))
 478                      (cond ((>= left-margin 0) left-guess)
 479                            ((>= right-margin 0) right-guess)
 480                            ;; otherwise choose side we overlap less
 481                            ((> left-margin right-margin) 0)
 482                            (t (- (x-display-pixel-width) nfw 5))))
 483                    newtop pfy))
 484             ((eq location 'top-bottom)
 485              (setq newleft pfx
 486                    newtop
 487                    ;; Try and guess if we should be on the top or bottom.
 488                    (let* ((top-guess (- pfy 15 nfh))
 489                           (bottom-guess (+ pfy 5 pfh))
 490                           (top-margin top-guess)
 491                           (bottom-margin (- (x-display-pixel-height)
 492                                             bottom-guess 5 nfh)))
 493                      (cond ((>= top-margin 0) top-guess)
 494                            ((>= bottom-margin 0) bottom-guess)
 495                            ;; Choose a side to overlap the least.
 496                            ((> top-margin bottom-margin) 0)
 497                            (t (- (x-display-pixel-height) nfh 5))))))
 498             ((consp location)
 499              (setq newleft (or (car location) 0)
 500                    newtop (or (cdr location) 0)))
 501             (t nil))
 502       (modify-frame-parameters new-frame
 503                                (list (cons 'left newleft)
 504                                      (cons 'top newtop))))))
 505
 506 (defun dframe-reposition-frame-xemacs (new-frame parent-frame location)
 507   "Move NEW-FRAME to be relative to PARENT-FRAME.
 508 LOCATION can be one of 'random, 'left-right, or 'top-bottom."
 509   ;; Not yet implemented
 510   )
 511
 512 ;; XEmacs function only.
 513 (defun dframe-needed-height (&optional frame)
 514   "The needed height for the tool bar FRAME (in characters)."
 515   (or frame (setq frame (selected-frame)))
 516   ;; The 1 is the missing modeline/minibuffer
 517   (+ 1 (/ (frame-pixel-height frame)
 518           ;; This obscure code avoids a byte compiler warning in Emacs.
 519           (let ((f 'face-height))
 520             (funcall f 'default frame)))))
 521
 522 (defun dframe-detach (frame-var cache-var buffer-var)
 523   "Detatch the frame in symbol FRAME-VAR.
 524 CACHE-VAR and BUFFER-VAR are symbols as in `dframe-frame-mode'"
 525   (with-current-buffer (symbol-value buffer-var)
 526     (rename-buffer (buffer-name) t)
 527     (let ((oldframe (symbol-value frame-var)))
 528       (set buffer-var nil)
 529       (set frame-var nil)
 530       (set cache-var nil)
 531       ;; FIXME: Looks very suspicious.  Luckily this function is unused.
 532       (make-variable-buffer-local frame-var)
 533       (set frame-var oldframe)
 534       )))
 535
 536 ;;; Special frame event proxies
 537 ;;
 538 (if (boundp 'special-event-map)
 539     (progn
 540       (define-key special-event-map [make-frame-visible]
 541         'dframe-handle-make-frame-visible)
 542       (define-key special-event-map [iconify-frame]
 543         'dframe-handle-iconify-frame)
 544       (define-key special-event-map [delete-frame]
 545         'dframe-handle-delete-frame))
 546   )
 547
 548 (defvar dframe-make-frame-visible-function nil
 549   "Function used when a dframe controlled frame is de-iconified.
 550 The function must take an EVENT.")
 551 (defvar dframe-iconify-frame-function nil
 552   "Function used when a dframe controlled frame is iconified.
 553 The function must take an EVENT.")
 554 (defvar dframe-delete-frame-function nil
 555   "Function used when a frame attached to a dframe frame is deleted.
 556 The function must take an EVENT.")
 557
 558 (defun dframe-handle-make-frame-visible (e)
 559   "Handle a `make-frame-visible' event.
 560 Should enable auto-updating if the last state was also enabled.
 561 Argument E is the event making the frame visible."
 562   (interactive "e")
 563   (let ((f last-event-frame))
 564     (if (and (dframe-attached-frame f)
 565              dframe-make-frame-visible-function)
 566         (funcall dframe-make-frame-visible-function e)
 567       )))
 568
 569 (defun dframe-handle-iconify-frame (e)
 570   "Handle a `iconify-frame' event.
 571 Should disable auto-updating if the last state was also enabled.
 572 Argument E is the event iconifying the frame."
 573   (interactive "e")
 574   (let ((f last-event-frame))
 575     (if (and (dframe-attached-frame f)
 576              dframe-iconify-frame-function e)
 577         (funcall dframe-iconify-frame-function)
 578       )))
 579
 580 (defun dframe-handle-delete-frame (e)
 581   "Handle `delete-frame' event.
 582 Argument E is the event deleting the frame."
 583   (interactive "e")
 584   (let ((fl (frame-list))
 585         (sf (selected-frame)))
 586     ;; Loop over all frames.  If dframe-delete-frame-function is
 587     ;; non-nil, call it.
 588     (while fl
 589       (select-frame (car fl))
 590       (if dframe-delete-frame-function
 591           (funcall dframe-delete-frame-function e))
 592       (setq fl (cdr fl)))
 593     (if (frame-live-p sf)
 594         (select-frame sf))
 595     (handle-delete-frame e)))
 596
 597
 598 ;;; Utilities
 599 ;;
 600 (defun dframe-get-focus (frame-var activator &optional hook)
 601   "Change frame focus to or from a dedicated frame.
 602 If the selected frame is not in the symbol FRAME-VAR, then FRAME-VAR
 603 frame is selected.  If the FRAME-VAR is active, then select the
 604 attached frame.  If FRAME-VAR is nil, ACTIVATOR is called to
 605 created it.  HOOK is an optional argument of hooks to run when
 606 selecting FRAME-VAR."
 607   (interactive)
 608   (if (eq (selected-frame) (symbol-value frame-var))
 609       (if (frame-live-p dframe-attached-frame)
 610           (dframe-select-attached-frame))
 611     ;; make sure we have a frame
 612     (if (not (frame-live-p (symbol-value frame-var)))
 613         (funcall activator 1))
 614     ;; go there
 615     (select-frame (symbol-value frame-var))
 616     )
 617   (other-frame 0)
 618   ;; If updates are off, then refresh the frame (they want it now...)
 619   (run-hooks 'hook))
 620
 621
 622 (defun dframe-close-frame ()
 623   "Close the current frame if it is dedicated."
 624   (interactive)
 625   (if dframe-controlled
 626       (let ((b (current-buffer)))
 627         (funcall dframe-controlled -1)
 628         (kill-buffer b))))
 629
 630 (defun dframe-current-frame (frame-var desired-major-mode)
 631   "Return the existing dedicated frame to use.
 632 FRAME-VAR is the variable storing the currently active dedicated frame.
 633 If the current frame's buffer uses DESIRED-MAJOR-MODE, then use that frame."
 634   (if (not (eq (selected-frame) (symbol-value frame-var)))
 635       (if (and (eq major-mode 'desired-major-mode)
 636                (get-buffer-window (current-buffer))
 637                (window-frame (get-buffer-window (current-buffer))))
 638           (window-frame (get-buffer-window (current-buffer)))
 639         (symbol-value frame-var))
 640     (symbol-value frame-var)))
 641
 642 (defun dframe-attached-frame (&optional frame)
 643   "Return the attached frame belonging to the dframe controlled frame FRAME.
 644 If optional arg FRAME is nil just return `dframe-attached-frame'."
 645   (save-excursion
 646     (if frame (select-frame frame))
 647     dframe-attached-frame))
 648
 649 (defun dframe-select-attached-frame (&optional frame)
 650   "Switch to the frame the dframe controlled frame FRAME was started from.
 651 If optional arg FRAME is nil assume the attached frame is already selected
 652 and just run the hooks `dframe-after-select-attached-frame-hook'.  Return
 653 the attached frame."
 654   (let ((frame (dframe-attached-frame frame)))
 655     (if frame (select-frame frame))
 656     (prog1 frame
 657       (run-hooks 'dframe-after-select-attached-frame-hook))))
 658
 659 (defmacro dframe-with-attached-buffer (&rest forms)
 660   "Execute FORMS in the attached frame's special buffer.
 661 Optionally select that frame if necessary."
 662   `(save-selected-window
 663      ;;(speedbar-set-timer speedbar-update-speed)
 664      (dframe-select-attached-frame)
 665      ,@forms
 666      (dframe-maybee-jump-to-attached-frame)))
 667
 668 (defun dframe-maybee-jump-to-attached-frame ()
 669   "Jump to the attached frame ONLY if this was not a mouse event."
 670   (when (or (not (dframe-mouse-event-p last-input-event))
 671             dframe-activity-change-focus-flag)
 672     (dframe-select-attached-frame)
 673     ;; KB: For what is this - raising the frame??
 674     (other-frame 0)))
 675
 676
 677 (defvar dframe-suppress-message-flag nil
 678   "Non-nil means that `dframe-message' should just return a string.")
 679
 680 (defun dframe-message (fmt &rest args)
 681   "Like message, but for use in a dedicated frame.
 682 Argument FMT is the format string, and ARGS are the arguments for message."
 683   (save-selected-window
 684     (if dframe-suppress-message-flag
 685         (apply 'format fmt args)
 686       (if dframe-attached-frame
 687           ;; KB: Here we do not need calling `dframe-select-attached-frame'
 688           (select-frame dframe-attached-frame))
 689       (apply 'message fmt args))))
 690
 691 (defun dframe-y-or-n-p (prompt)
 692   "Like `y-or-n-p', but for use in a dedicated frame.
 693 Argument PROMPT is the prompt to use."
 694   (save-selected-window
 695     (if (and ;;default-minibuffer-frame
 696              dframe-attached-frame
 697              ;;(not (eq default-minibuffer-frame dframe-attached-frame))
 698              )
 699         ;; KB: Here we do not need calling `dframe-select-attached-frame'
 700         (select-frame dframe-attached-frame))
 701     (y-or-n-p prompt)))
 702 \f
 703 ;;; timer management
 704 ;;
 705 ;; Unlike speedbar with a dedicated set of routines, dframe has one master
 706 ;; timer, and all dframe users will use it.  At least until I figure out a way
 707 ;; around that problem.
 708 ;;
 709 ;; Advantage 1: Two apps with timer/frames can munge the master list
 710 ;;              to make sure they occur in order.
 711 ;; Advantage 2: If a user hits a key between timer functions, we can
 712 ;;              interrupt them safely.
 713 (defvar dframe-client-functions nil
 714   "List of client functions using the dframe timer.")
 715
 716 (defun dframe-set-timer (timeout fn &optional null-on-error)
 717   "Apply a timer with TIMEOUT, to call FN, or remove a timer if TIMEOUT is nil.
 718 TIMEOUT is the number of seconds until the dframe controled program
 719 timer is called again.  When TIMEOUT is nil, turn off all timeouts.
 720 This function must be called from the buffer belonging to the program
 721 who requested the timer.
 722 If NULL-ON-ERROR is a symbol, set it to nil if we cannot create a timer."
 723   ;; First, fix up our list of client functions
 724   (if timeout
 725       (add-to-list 'dframe-client-functions fn)
 726     (setq dframe-client-functions (delete fn dframe-client-functions)))
 727   ;; Now decided what to do about the timout.
 728   (if (or
 729        ;; We have a timer, restart the timer with the new time.
 730        timeout
 731        ;; We have a timer, an off is requested, and no client
 732        ;; functions are left, shut er down.
 733        (and dframe-timer (not timeout) dframe-client-functions))
 734       ;; Only call the low level function if we are changing the state.
 735       (dframe-set-timer-internal timeout null-on-error)))
 736
 737 (defun dframe-set-timer-internal (timeout &optional null-on-error)
 738   "Apply a timer with TIMEOUT to call the dframe timer manager."
 739   (when dframe-timer
 740     (if (featurep 'xemacs)
 741         (delete-itimer dframe-timer)
 742       (cancel-timer dframe-timer))
 743     (setq dframe-timer nil))
 744   (when timeout
 745     (setq dframe-timer
 746           (if (featurep 'xemacs)
 747               (start-itimer "dframe" 'dframe-timer-fn
 748                             timeout timeout t)
 749             (run-with-idle-timer timeout t 'dframe-timer-fn)))))
 750
 751 (defun dframe-timer-fn ()
 752   "Called due to the dframe timer.
 753 Evaluates all cached timer functions in sequence."
 754   (let ((l dframe-client-functions))
 755     (while (and l (sit-for 0))
 756       (condition-case er
 757           (funcall (car l))
 758         (error (message "DFRAME TIMER ERROR: %S" er)))
 759       (setq l (cdr l)))))
 760
 761 ;;; Menu hacking for mouse-3
 762 ;;
 763 (defconst dframe-pass-event-to-popup-mode-menu
 764   (let (max-args)
 765     (and (fboundp 'popup-mode-menu)
 766          (fboundp 'function-max-args)
 767          (setq max-args (function-max-args 'popup-mode-menu))
 768          (not (zerop max-args))))
 769   "The EVENT arg to `popup-mode-menu' was introduced in XEmacs 21.4.0.")
 770
 771 ;; In XEmacs, we make popup menus work on the item over mouse (as
 772 ;; opposed to where the point happens to be.)  We attain this by
 773 ;; temporarily moving the point to that place.
 774 ;;    Hrvoje Niksic <hniksic@srce.hr>
 775 (defalias 'dframe-popup-kludge
 776   (if (featurep 'xemacs)
 777       (lambda (event)                        ; XEmacs.
 778         "Pop up a menu related to the clicked on item.
 779 Must be bound to EVENT."
 780         (interactive "e")
 781         (save-excursion
 782           (if dframe-pass-event-to-popup-mode-menu
 783               (popup-mode-menu event)
 784             (goto-char (event-closest-point event))
 785             (beginning-of-line)
 786             (forward-char (min 5 (- (save-excursion (end-of-line) (point))
 787                                     (save-excursion (beginning-of-line) (point)))))
 788             (popup-mode-menu))
 789           ;; Wait for menu to bail out.  `popup-mode-menu' (and other popup
 790           ;; menu functions) return immediately.
 791           (let (new)
 792             (while (not (misc-user-event-p (setq new (next-event))))
 793               (dispatch-event new))
 794             (dispatch-event new))))
 795
 796     (lambda (e)                              ; Emacs.
 797       "Pop up a menu related to the clicked on item.
 798 Must be bound to event E."
 799       (interactive "e")
 800       (save-excursion
 801         (mouse-set-point e)
 802         ;; This gets the cursor where the user can see it.
 803         (if (not (bolp)) (forward-char -1))
 804         (sit-for 0)
 805         (if (fboundp 'mouse-menu-major-mode-map)
 806             (popup-menu (mouse-menu-major-mode-map) e)
 807           (with-no-warnings       ; don't warn about obsolete fallback
 808             (mouse-major-mode-menu e nil)))))))
 809
 810 ;;; Interactive user functions for the mouse
 811 ;;
 812 (defalias 'dframe-mouse-event-p
 813   (if (featurep 'xemacs)
 814       'button-press-event-p
 815     (lambda (event)
 816       "Return t if the event is a mouse related event."
 817       (if (and (listp event)
 818                (member (event-basic-type event)
 819                        '(mouse-1 mouse-2 mouse-3)))
 820           t
 821         nil))))
 822
 823 (defun dframe-track-mouse (event)
 824   "For motion EVENT, display info about the current line."
 825   (interactive "e")
 826   (when (and dframe-track-mouse-function
 827              (or (featurep 'xemacs) ;; XEmacs always safe?
 828                  (windowp (posn-window (event-end event))) ; Sometimes
 829                                         ; there is no window to jump into.
 830                  ))
 831
 832     (funcall dframe-track-mouse-function event)))
 833
 834 (defun dframe-track-mouse-xemacs (event)
 835   "For motion EVENT, display info about the current line."
 836   (if (functionp (default-value 'mouse-motion-handler))
 837       (funcall (default-value 'mouse-motion-handler) event))
 838   (if dframe-track-mouse-function
 839       (funcall dframe-track-mouse-function event)))
 840
 841 (defun dframe-help-echo (window &optional buffer position)
 842   "Display help based context.
 843 The context is in WINDOW, viewing BUFFER, at POSITION.
 844 BUFFER and POSITION are optional because XEmacs doesn't use them."
 845   (when (and (not dframe-track-mouse-function)
 846              (bufferp buffer)
 847              dframe-help-echo-function)
 848     (let ((dframe-suppress-message-flag t))
 849       (with-current-buffer buffer
 850         (save-excursion
 851           (if position (goto-char position))
 852           (funcall dframe-help-echo-function))))))
 853
 854 (defun dframe-mouse-set-point (e)
 855   "Set point based on event E.
 856 Handles clicking on images in XEmacs."
 857   (if (and (featurep 'xemacs)
 858            (save-excursion
 859              (save-window-excursion
 860                (mouse-set-point e)
 861                (event-over-glyph-p e))))
 862       ;; We are in XEmacs, and clicked on a picture
 863       (let ((ext (event-glyph-extent e)))
 864         ;; This position is back inside the extent where the
 865         ;; junk we pushed into the property list lives.
 866         (if (extent-end-position ext)
 867             (goto-char (1- (extent-end-position ext)))
 868           (mouse-set-point e)))
 869     ;; We are not in XEmacs, OR we didn't click on a picture.
 870     (mouse-set-point e)))
 871
 872 (defun dframe-quick-mouse (e)
 873   "Since mouse events are strange, this will keep the mouse nicely positioned.
 874 This should be bound to mouse event E."
 875   (interactive "e")
 876   (dframe-mouse-set-point e)
 877   (if dframe-mouse-position-function
 878       (funcall dframe-mouse-position-function)))
 879
 880 (defun dframe-power-click (e)
 881   "Activate any dframe mouse click as a power click.
 882 A power click will dispose of cached data (if available) or bring a buffer
 883 up into a different window.
 884 This should be bound to mouse event E."
 885   (interactive "e")
 886   (let ((dframe-power-click t))
 887     (select-frame last-event-frame)
 888     (dframe-click e)))
 889
 890 (defun dframe-click (e)
 891   "Call our clients click function on a user click.
 892 E is the event causing the click."
 893   (interactive "e")
 894   (dframe-mouse-set-point e)
 895   (when dframe-mouse-click-function
 896     ;; On the off chance of buffer switch, or something incorrectly
 897     ;; configured.
 898     (funcall dframe-mouse-click-function e)))
 899
 900 (defun dframe-double-click (e)
 901   "Activate the registered click function on a double click.
 902 This must be bound to a mouse event.
 903 This should be bound to mouse event E."
 904   (interactive "e")
 905   ;; Emacs only.  XEmacs handles this via `mouse-track-click-hook'.
 906   (cond ((eq (car e) 'down-mouse-1)
 907          (dframe-mouse-set-point e))
 908         ((eq (car e) 'mouse-1)
 909          (dframe-quick-mouse e))
 910         ((or (eq (car e) 'double-down-mouse-1)
 911              (eq (car e) 'triple-down-mouse-1))
 912          (dframe-click e))))
 913
 914 ;;; Hacks of normal things.
 915 ;;
 916 ;; Some normal things that happen in one of these dedicated frames
 917 ;; must be handled specially, so that our dedicated frame isn't
 918 ;; messed up.
 919 (defun dframe-temp-buffer-show-function (buffer)
 920   "Placed in the variable `temp-buffer-show-function' in dedicated frames.
 921 If a user requests help using \\[help-command] <Key> the temp BUFFER will be
 922 redirected into a window on the attached frame."
 923   (if dframe-attached-frame (dframe-select-attached-frame))
 924   (pop-to-buffer buffer nil)
 925   (other-window -1)
 926   ;; Fix for using this hook on some platforms: Bob Weiner
 927   (cond ((not (featurep 'xemacs))
 928          (run-hooks 'temp-buffer-show-hook))
 929         ((fboundp 'run-hook-with-args)
 930          (run-hook-with-args 'temp-buffer-show-hook buffer))
 931         ((and (boundp 'temp-buffer-show-hook)
 932               (listp temp-buffer-show-hook))
 933          (mapcar (function (lambda (hook) (funcall hook buffer)))
 934                  temp-buffer-show-hook))))
 935
 936 (defun dframe-hack-buffer-menu (e)
 937   "Control mouse 1 is buffer menu.
 938 This hack overrides it so that the right thing happens in the main
 939 Emacs frame, not in the dedicated frame.
 940 Argument E is the event causing this activity."
 941   (interactive "e")
 942   (let ((fn (lookup-key global-map (if (featurep 'xemacs)
 943                                        '(control button1)
 944                                      [C-down-mouse-1])))
 945         (oldbuff (current-buffer))
 946         (newbuff nil))
 947     (unwind-protect
 948         (save-excursion
 949           (set-window-dedicated-p (selected-window) nil)
 950           (call-interactively fn)
 951           (setq newbuff (current-buffer)))
 952       (switch-to-buffer oldbuff)
 953       (set-window-dedicated-p (selected-window) t))
 954     (if (not (eq newbuff oldbuff))
 955         (dframe-with-attached-buffer
 956          (switch-to-buffer newbuff)))))
 957
 958 (defun dframe-switch-buffer-attached-frame (&optional buffer)
 959   "Switch to BUFFER in the attached frame, and raise that frame.
 960 This overrides the default behavior of `switch-to-buffer' which is
 961 broken because of the dedicated frame."
 962   (interactive)
 963   ;; Assume we are in the dedicated frame.
 964   (other-frame 1)
 965   ;; Now switch buffers
 966   (if buffer
 967       (switch-to-buffer buffer)
 968     (call-interactively 'switch-to-buffer nil nil)))
 969
 970 ;; XEmacs: this can be implemented using modeline keymaps, but there
 971 ;; is no use, as we have horizontal scrollbar (as the docstring
 972 ;; hints.)
 973 (defun dframe-mouse-hscroll (e)
 974   "Read a mouse event E from the mode line, and horizontally scroll.
 975 If the mouse is being clicked on the far left, or far right of the
 976 mode-line.  This is only useful for non-XEmacs."
 977   (interactive "e")
 978   (let* ((x-point (car (nth 2 (car (cdr e)))))
 979          (pixels-per-10-col (/ (* 10 (frame-pixel-width))
 980                                (frame-width)))
 981          (click-col (1+ (/ (* 10 x-point) pixels-per-10-col)))
 982          )
 983     (cond ((< click-col 3)
 984            (scroll-left 2))
 985           ((> click-col (- (window-width) 5))
 986            (scroll-right 2))
 987           (t (dframe-message
 988               "Click on the edge of the modeline to scroll left/right")))
 989     ))
 990
 991 (provide 'dframe)
 992
 993 ;; arch-tag: df9b91b6-e85e-4a76-a02e-b3cb5b686bd4
 994 ;;; dframe.el ends here