lisp/dframe.el

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