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