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