cgit.sxemacs.org Git - packages/blob - xemacs-packages/speedbar/dframe.el

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