;;; dframe --- dedicate frame support modes
;;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007 Free Software Foundation, Inc.
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
;; Keywords: file, tags, tools
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; * Frame/buffer killing hooks
;; * Mouse-3 position relative menu
;; * Mouse motion, help-echo hacks
-;; * Mouse clicking, double clicking, & Xemacs image clicking hack
+;; * Mouse clicking, double clicking, & XEmacs image clicking hack
;; * Mode line hacking
;; * Utilities for use in a program covering:
;; o keymap massage for some actions
;;; Bugs
;;
;; * The timer managers doesn't handle multiple different timeouts.
-;; * You can't specify continuous timouts (as opposed to just lidle timers.)
+;; * You can't specify continuous timeouts (as opposed to just idle timers.)
(defvar x-pointer-hand2)
(defvar x-pointer-top-left-arrow)
;;; Code:
-(defvar dframe-xemacsp (string-match "XEmacs" emacs-version)
- "Non-nil if we are running in the XEmacs environment.")
-(defvar dframe-xemacs20p (and dframe-xemacsp
- (>= emacs-major-version 20)))
-
-;; From custom web page for compatibility between versions of custom
-;; with help from ptype@dera.gov.uk (Proto Type)
-(eval-and-compile
- (condition-case ()
- (require 'custom)
- (error nil))
- (if (and (featurep 'custom) (fboundp 'custom-declare-variable)
- ;; Some XEmacsen w/ custom don't have :set keyword.
- ;; This protects them against custom.
- (fboundp 'custom-initialize-set))
- nil ;; We've got what we needed
- ;; We have the old custom-library, hack around it!
- (if (boundp 'defgroup)
- nil
- (defmacro defgroup (&rest args)
- nil))
- (if (boundp 'defface)
- nil
- (defmacro defface (var values doc &rest args)
- (` (progn
- (defvar (, var) (quote (, var)))
- ;; To make colors for your faces you need to set your .Xdefaults
- ;; or set them up ahead of time in your .emacs file.
- (make-face (, var))
- ))))
- (if (boundp 'defcustom)
- nil
- (defmacro defcustom (var value doc &rest args)
- (` (defvar (, var) (, value) (, doc)))))))
-
\f
;;; Compatibility functions
;;
-(if (fboundp 'frame-parameter)
-
- (defalias 'dframe-frame-parameter 'frame-parameter)
-
- (defun dframe-frame-parameter (frame parameter)
- "Return FRAME's PARAMETER value."
- (cdr (assoc parameter (frame-parameters frame)))))
+(defalias 'dframe-frame-parameter
+ (if (fboundp 'frame-parameter) 'frame-parameter
+ (lambda (frame parameter)
+ "Return FRAME's PARAMETER value."
+ (cdr (assoc parameter (frame-parameters frame))))))
\f
;;; Variables
:prefix "dframe-"
:group 'dframe)
-(defvar dframe-have-timer-flag
- (and (or (fboundp 'run-with-idle-timer)
- (fboundp 'start-itimer)
- (boundp 'post-command-idle-hook))
- (if (fboundp 'display-graphic-p)
- (display-graphic-p)
- window-system))
- "Non-nil means that timers are available for this Emacs.")
+(defvar dframe-have-timer-flag (if (fboundp 'display-graphic-p)
+ (display-graphic-p)
+ window-system)
+ "Non-nil means that timers are available for this Emacs.
+This is nil for terminals, since updating a frame in a terminal
+is not useful to the user.")
(defcustom dframe-update-speed
- (if dframe-xemacsp
- (if dframe-xemacs20p
- 2 ; 1 is too obrusive in XEmacs
- 5) ; when no idleness, need long delay
+ (if (featurep 'xemacs) 2 ; 1 is too obrusive in XEmacs
1)
- "*Idle time in seconds needed before dframe will update itself.
+ "Idle time in seconds needed before dframe will update itself.
Updates occur to allow dframe to display directory information
relevant to the buffer you are currently editing."
:group 'dframe
:type 'integer)
(defcustom dframe-activity-change-focus-flag nil
- "*Non-nil means the selected frame will change based on activity.
+ "Non-nil means the selected frame will change based on activity.
Thus, if a file is selected for edit, the buffer will appear in the
selected frame and the focus will change to that frame."
:group 'dframe
:type 'boolean)
(defcustom dframe-after-select-attached-frame-hook nil
- "*Hook run after dframe has selected the attached frame."
+ "Hook run after dframe has selected the attached frame."
:group 'dframe
:type 'hook)
(make-variable-buffer-local 'dframe-mouse-click-function)
(defvar dframe-mouse-position-function nil
- "*A function to called to position the cursor for a mouse click.")
+ "*A function to call to position the cursor for a mouse click.")
(make-variable-buffer-local 'dframe-mouse-position-function)
(defvar dframe-power-click nil
'dframe-switch-buffer-attached-frame
map global-map)
- (if dframe-xemacsp
+ (if (featurep 'xemacs)
(progn
;; mouse bindings so we can manipulate the items on each line
(define-key map 'button2 'dframe-click)
;; Info doc fix from Bob Weiner
(if (featurep 'infodoc)
nil
- (define-key map 'button3 'dframe-xemacs-popup-kludge))
+ (define-key map 'button3 'dframe-popup-kludge))
)
;; mouse bindings so we can manipulate the items on each line
;; This adds a small unecessary visual effect
;;(define-key map [down-mouse-2] 'dframe-quick-mouse)
- (define-key map [down-mouse-3] 'dframe-emacs-popup-kludge)
+ (define-key map [down-mouse-3] 'dframe-popup-kludge)
;; This lets the user scroll as if we had a scrollbar... well maybe not
(define-key map [mode-line mouse-2] 'dframe-mouse-hscroll)
;; another handy place users might click to get our menu.
(define-key map [mode-line down-mouse-1]
- 'dframe-emacs-popup-kludge)
+ 'dframe-popup-kludge)
;; We can't switch buffers with the buffer mouse menu. Lets hack it.
(define-key map [C-down-mouse-1] 'dframe-hack-buffer-menu)
(run-hooks 'popup-hook)
;; Updated the buffer passed in to contain all the hacks needed
;; to make it work well in a dedicated window.
- (save-excursion
- (set-buffer (symbol-value buffer-var))
+ (with-current-buffer (symbol-value buffer-var)
;; Declare this buffer a dedicated frame
(setq dframe-controlled local-mode-fn)
- (if dframe-xemacsp
- ;; Hack the XEmacs mouse-motion handler
- (with-no-warnings
+ (if (featurep 'xemacs)
+ (progn
;; Hack the XEmacs mouse-motion handler
(set (make-local-variable 'mouse-motion-handler)
'dframe-track-mouse-xemacs)
t))))
;; Enable mouse tracking in emacs
(if dframe-track-mouse-function
- (set (make-local-variable 'track-mouse) t)) ;this could be messy.
- ;; disable auto-show-mode for Emacs
- (setq auto-show-mode nil))
-;;;; DISABLED: This causes problems for users with multiple frames.
+ (set (make-local-variable 'track-mouse) t))) ;this could be messy.
+;;;; DISABLED: This causes problems for users with multiple frames.
;;;; ;; Set this up special just for the passed in buffer
;;;; ;; Terminal minibuffer stuff does not require this.
;;;; (if (and (or (assoc 'minibuffer parameters)
(if (frame-live-p (symbol-value frame-var))
(raise-frame (symbol-value frame-var))
(set frame-var
- (if dframe-xemacsp
+ (if (featurep 'xemacs)
;; Only guess height if it is not specified.
(if (member 'height parameters)
(make-frame parameters)
paramsa
(list (cons 'width (frame-width))))))
(frame
- (if (or (< emacs-major-version 20)
- (not (eq window-system 'x)))
+ (if (not (eq window-system 'x))
(make-frame params)
(let ((x-pointer-shape x-pointer-top-left-arrow)
(x-sensitive-text-pointer-shape
(defun dframe-reposition-frame (new-frame parent-frame location)
"Move NEW-FRAME to be relative to PARENT-FRAME.
LOCATION can be one of 'random, 'left, 'right, 'left-right, or 'top-bottom."
- (if dframe-xemacsp
+ (if (featurep 'xemacs)
(dframe-reposition-frame-xemacs new-frame parent-frame location)
(dframe-reposition-frame-emacs new-frame parent-frame location)))
+;; Not defined in builds without X, but behind window-system test.
+(declare-function x-display-pixel-width "xfns.c" (&optional terminal))
+(declare-function x-display-pixel-height "xfns.c" (&optional terminal))
+
(defun dframe-reposition-frame-emacs (new-frame parent-frame location)
"Move NEW-FRAME to be relative to PARENT-FRAME.
LOCATION can be one of 'random, 'left-right, 'top-bottom, or
-a cons cell indicationg a position of the form (LEFT . TOP)."
- (let* ((pfx (dframe-frame-parameter parent-frame 'left))
- (pfy (dframe-frame-parameter parent-frame 'top))
- (pfw (frame-pixel-width parent-frame))
- (pfh (frame-pixel-height parent-frame))
- (nfw (frame-pixel-width new-frame))
- (nfh (frame-pixel-height new-frame))
- newleft newtop
- )
- ;; Position dframe.
- (if (or (not window-system) (eq window-system 'pc))
- ;; Do no positioning if not on a windowing system,
- nil
+a cons cell indicating a position of the form (LEFT . TOP)."
+ ;; Position dframe.
+ ;; Do no positioning if not on a windowing system,
+ (unless (or (not window-system) (eq window-system 'pc))
+ (let* ((pfx (dframe-frame-parameter parent-frame 'left))
+ (pfy (dframe-frame-parameter parent-frame 'top))
+ (pfw (frame-pixel-width parent-frame))
+ (pfh (frame-pixel-height parent-frame))
+ (nfw (frame-pixel-width new-frame))
+ (nfh (frame-pixel-height new-frame))
+ newleft newtop)
;; Rebuild pfx,pfy to be absolute positions.
(setq pfx (if (not (consp pfx))
pfx
;; A - means distance from the right edge
;; of the display, or DW - pfx - framewidth
(- (x-display-pixel-height) (car (cdr pfy)) pfh)
- (car (cdr pfy))))
- )
+ (car (cdr pfy)))))
(cond ((eq location 'right)
(setq newleft (+ pfx pfw 5)
newtop pfy))
;; otherwise choose side we overlap less
((> left-margin right-margin) 0)
(t (- (x-display-pixel-width) nfw 5))))
- newtop pfy
- ))
+ newtop pfy))
((eq location 'top-bottom)
(setq newleft pfx
newtop
((>= bottom-margin 0) bottom-guess)
;; Choose a side to overlap the least.
((> top-margin bottom-margin) 0)
- (t (- (x-display-pixel-height) nfh 5)))))
- )
+ (t (- (x-display-pixel-height) nfh 5))))))
((consp location)
(setq newleft (or (car location) 0)
newtop (or (cdr location) 0)))
(t nil))
(modify-frame-parameters new-frame
- (list (cons 'left newleft)
- (cons 'top newtop))))))
+ (list (cons 'left newleft)
+ (cons 'top newtop))))))
(defun dframe-reposition-frame-xemacs (new-frame parent-frame location)
"Move NEW-FRAME to be relative to PARENT-FRAME.
(defun dframe-detach (frame-var cache-var buffer-var)
"Detatch the frame in symbol FRAME-VAR.
CACHE-VAR and BUFFER-VAR are symbols as in `dframe-frame-mode'"
- (save-excursion
- (set-buffer (symbol-value buffer-var))
+ (with-current-buffer (symbol-value buffer-var)
(rename-buffer (buffer-name) t)
(let ((oldframe (symbol-value frame-var)))
(set buffer-var nil)
(set frame-var nil)
(set cache-var nil)
+ ;; FIXME: Looks very suspicious. Luckily this function is unused.
(make-variable-buffer-local frame-var)
(set frame-var oldframe)
)))
(dframe-set-timer-internal timeout null-on-error)))
(defun dframe-set-timer-internal (timeout &optional null-on-error)
- "Apply a timer with TIMEOUT to call the dframe timer manager.
-If NULL-ON-ERROR is a symbol, set it to nil if we cannot create a timer."
- (cond
- ;; XEmacs
- (dframe-xemacsp
- (with-no-warnings
- (if dframe-timer
- (progn (delete-itimer dframe-timer)
- (setq dframe-timer nil)))
- (if timeout
- (if (and dframe-xemacsp
- (or (>= emacs-major-version 21)
- (and (= emacs-major-version 20)
- (> emacs-minor-version 0))
- (and (= emacs-major-version 19)
- (>= emacs-minor-version 15))))
- (setq dframe-timer (start-itimer "dframe"
- 'dframe-timer-fn
- timeout
- timeout
- t))
- (setq dframe-timer (start-itimer "dframe"
- 'dframe-timer-fn
- timeout
- nil))))))
- ;; Post 19.31 Emacs
- ((fboundp 'run-with-idle-timer)
- (if dframe-timer
- (progn (cancel-timer dframe-timer)
- (setq dframe-timer nil)))
- (if timeout
- (setq dframe-timer
- (run-with-idle-timer timeout t 'dframe-timer-fn))))
- ;; Emacs 19.30 (Thanks twice: ptype@dra.hmg.gb)
- ((fboundp 'post-command-idle-hook)
- (if timeout
- (add-hook 'post-command-idle-hook 'dframe-timer-fn)
- (remove-hook 'post-command-idle-hook 'dframe-timer-fn)))
- ;; Older or other Emacsen with no timers. Set up so that its
- ;; obvious this emacs can't handle the updates
- ((symbolp null-on-error)
- (set null-on-error nil)))
- )
+ "Apply a timer with TIMEOUT to call the dframe timer manager."
+ (when dframe-timer
+ (if (featurep 'xemacs)
+ (delete-itimer dframe-timer)
+ (cancel-timer dframe-timer))
+ (setq dframe-timer nil))
+ (when timeout
+ (setq dframe-timer
+ (if (featurep 'xemacs)
+ (start-itimer "dframe" 'dframe-timer-fn
+ timeout timeout t)
+ (run-with-idle-timer timeout t 'dframe-timer-fn)))))
(defun dframe-timer-fn ()
"Called due to the dframe timer.
(fboundp 'function-max-args)
(setq max-args (function-max-args 'popup-mode-menu))
(not (zerop max-args))))
- "The EVENT arg to 'popup-mode-menu' was introduced in XEmacs 21.4.0.")
+ "The EVENT arg to `popup-mode-menu' was introduced in XEmacs 21.4.0.")
;; In XEmacs, we make popup menus work on the item over mouse (as
;; opposed to where the point happens to be.) We attain this by
;; temporarily moving the point to that place.
;; Hrvoje Niksic <hniksic@srce.hr>
-(with-no-warnings
-(defun dframe-xemacs-popup-kludge (event)
- "Pop up a menu related to the clicked on item.
+(defalias 'dframe-popup-kludge
+ (if (featurep 'xemacs)
+ (lambda (event) ; XEmacs.
+ "Pop up a menu related to the clicked on item.
Must be bound to EVENT."
- (interactive "e")
- (save-excursion
- (if dframe-pass-event-to-popup-mode-menu
- (popup-mode-menu event)
- (goto-char (event-closest-point event))
- (beginning-of-line)
- (forward-char (min 5 (- (save-excursion (end-of-line) (point))
- (save-excursion (beginning-of-line) (point)))))
- (popup-mode-menu))
- ;; Wait for menu to bail out. `popup-mode-menu' (and other popup
- ;; menu functions) return immediately.
- (let (new)
- (while (not (misc-user-event-p (setq new (next-event))))
- (dispatch-event new))
- (dispatch-event new))))
-);with-no-warnings
-
-(defun dframe-emacs-popup-kludge (e)
- "Pop up a menu related to the clicked on item.
+ (interactive "e")
+ (save-excursion
+ (if dframe-pass-event-to-popup-mode-menu
+ (popup-mode-menu event)
+ (goto-char (event-closest-point event))
+ (beginning-of-line)
+ (forward-char (min 5 (- (save-excursion (end-of-line) (point))
+ (save-excursion (beginning-of-line) (point)))))
+ (popup-mode-menu))
+ ;; Wait for menu to bail out. `popup-mode-menu' (and other popup
+ ;; menu functions) return immediately.
+ (let (new)
+ (while (not (misc-user-event-p (setq new (next-event))))
+ (dispatch-event new))
+ (dispatch-event new))))
+
+ (lambda (e) ; Emacs.
+ "Pop up a menu related to the clicked on item.
Must be bound to event E."
- (interactive "e")
- (save-excursion
- (mouse-set-point e)
- ;; This gets the cursor where the user can see it.
- (if (not (bolp)) (forward-char -1))
- (sit-for 0)
- (if (< emacs-major-version 20)
- (mouse-major-mode-menu e)
- (mouse-major-mode-menu e nil))))
+ (interactive "e")
+ (save-excursion
+ (mouse-set-point e)
+ ;; This gets the cursor where the user can see it.
+ (if (not (bolp)) (forward-char -1))
+ (sit-for 0)
+ (if (fboundp 'mouse-menu-major-mode-map)
+ (popup-menu (mouse-menu-major-mode-map) e)
+ (with-no-warnings ; don't warn about obsolete fallback
+ (mouse-major-mode-menu e nil)))))))
;;; Interactive user functions for the mouse
;;
-(if dframe-xemacsp
- (defalias 'dframe-mouse-event-p 'button-press-event-p)
- (defun dframe-mouse-event-p (event)
- "Return t if the event is a mouse related event."
- (if (and (listp event)
- (member (event-basic-type event)
- '(mouse-1 mouse-2 mouse-3)))
- t
- nil)))
+(defalias 'dframe-mouse-event-p
+ (if (featurep 'xemacs)
+ 'button-press-event-p
+ (lambda (event)
+ "Return t if the event is a mouse related event."
+ (if (and (listp event)
+ (member (event-basic-type event)
+ '(mouse-1 mouse-2 mouse-3)))
+ t
+ nil))))
(defun dframe-track-mouse (event)
"For motion EVENT, display info about the current line."
(interactive "e")
(when (and dframe-track-mouse-function
- (or dframe-xemacsp ;; XEmacs always safe?
+ (or (featurep 'xemacs) ;; XEmacs always safe?
(windowp (posn-window (event-end event))) ; Sometimes
; there is no window to jump into.
))
(funcall dframe-help-echo-function))))))
(defun dframe-mouse-set-point (e)
- "Set POINT based on event E.
+ "Set point based on event E.
Handles clicking on images in XEmacs."
- (if (save-excursion
- (save-window-excursion
- (mouse-set-point e)
- (and (fboundp 'event-over-glyph-p) (event-over-glyph-p e))))
+ (if (and (featurep 'xemacs)
+ (save-excursion
+ (save-window-excursion
+ (mouse-set-point e)
+ (event-over-glyph-p e))))
;; We are in XEmacs, and clicked on a picture
- (with-no-warnings
(let ((ext (event-glyph-extent e)))
;; This position is back inside the extent where the
;; junk we pushed into the property list lives.
(if (extent-end-position ext)
(goto-char (1- (extent-end-position ext)))
(mouse-set-point e)))
- );with-no-warnings
;; We are not in XEmacs, OR we didn't click on a picture.
(mouse-set-point e)))
(pop-to-buffer buffer nil)
(other-window -1)
;; Fix for using this hook on some platforms: Bob Weiner
- (cond ((not dframe-xemacsp)
+ (cond ((not (featurep 'xemacs))
(run-hooks 'temp-buffer-show-hook))
((fboundp 'run-hook-with-args)
(run-hook-with-args 'temp-buffer-show-hook buffer))
Emacs frame, not in the dedicated frame.
Argument E is the event causing this activity."
(interactive "e")
- (let ((fn (lookup-key global-map (if dframe-xemacsp
- '(control button1)
+ (let ((fn (lookup-key global-map (if (featurep 'xemacs)
+ '(control button1)
[C-down-mouse-1])))
(oldbuff (current-buffer))
(newbuff nil))