;;; frame-fns.el --- frame manipulation commands ;; Author: Noah Friedman ;; Created: 1992 ;; Public domain. ;; $Id: frame-fns.el,v 1.68 2023/10/15 06:31:11 friedman Exp $ ;;; Commentary: ;;; Code: (require 'list-fns) (require 'string-fns) (require 'buffer-fns) ;;; Do not add autoload cookies for these macros; any package which uses ;;; them should `require' this file explicitly. (defmacro disabling-buggy-dynamic-bytecode (&rest forms) "Temporarily disable any generation of dynamic bytecode \ for FORMS during compilation in Emacs 21 or earlier. This is to work around bugs in the byte compiler prior to Emacs 22. In those prior versions, the compiler generates bad bytecode when `byte-compile-dynamic' is non-nil and the parameter declaration of a function includes a non-interned symbol." (declare (indent 0) (debug t)) (if (string-lessp emacs-version "22") `(progn (eval-when-compile (put 'byte-compile-dynamic 'dynamic-bytecode-workaround byte-compile-dynamic) (setq byte-compile-dynamic nil)) ,@forms (eval-when-compile (setq byte-compile-dynamic (get 'byte-compile-dynamic 'dynamic-bytecode-workaround)))) `(progn ,@forms))) (defmacro save-current-frame (&rest body) "Execute BODY, saving and restoring the selected frame." (declare (indent 0)) (let ((orig-frame (make-symbol "orig-frame"))) `(let ((,orig-frame (selected-frame))) (unwind-protect (progn ,@body) (when (frame-live-p ,orig-frame) (select-frame ,orig-frame)))))) ;; Some X window operations, such as x-window-property, when passed a ;; window id, need to be in a frame on the display to which the window id ;; applies. For example, in order to get root window (id 0) properties, a ;; frame on that display must be selected first for id 0 to have the right ;; context. ;; ;; We also check if the resulting display has a window manager by checking ;; for a frame's parent-id and if there doesn't appear to be one, set ;; x-no-window-manager accordingly. (defmacro with-selected-display (display &rest body) "Execute BODY while a frame on DISPLAY is selected. DISPLAY may be a frame, display device name, or nil. If DISPLAY is not the display of the currently selected frame, the first frame on DISPLAY will be selected temporarily." (declare (indent 1) (debug t)) (let ((display-frames (make-symbol "display-frames"))) `(let ((,display-frames (frames-on-display-list (if (framep ,display) ;; Emacs 22 and earlier did not ;; handle frames as a display spec. (frame-parameter ,display 'display) ,display)))) (save-current-frame (unless (memq (selected-frame) ,display-frames) (select-frame (car ,display-frames))) (let ((x-no-window-manager (if (frame-parameter nil 'parent-id) x-no-window-manager t)) (process-environment (cons (format "DISPLAY=%s" (if (stringp ,display) ,display (frame-parameter ,display 'display))) process-environment))) ,@body))))) ;; In emacsen where both window-system and tty frames can exist in the same ;; process, some initializations may be dependent on what kind of frame ;; is in use; it's not enough to check the window system type once at startup. (defmacro for-frame-type (type name &rest body) "For frames of type TYPE, name a routine NAME which executes BODY. The forms are inserted onto the hook `after-make-frame-functions'. The BODY forms will only be evaluated for frames matching TYPE: immediately for each frame existing at definition time, and subsequently for each new frame at creation time. The forms are evaluated with the relevant frame currently selected; the first window on the frame is also selected, so that popups and minibuffer messages will show up in the right frame. TYPE may be a symbol or list of symbols: * when TYPE is `nil' or `tty', the forms will only be evaluated in console/tty frames. * when TYPE is t or `window-system', the forms will be evaluated in any frame on a bitmapped display (i.e. not console/tty frames). * when TYPE is a list of symbols, the forms will be evaluated in any frame whose value of the frame parameter `window-system' is a member of the list. * When TYPE is a list of symbols beginning with `not', the forms will be evaluated in any frame whose frame parameter `window-system' is *not* a member of the list. NAME can be any symbol, for reference when redefining a body of forms to be evaluated. Therefore unless you intentionally want to replace a previous set of forms that were labeled with that tag, do not reuse symbol names." (declare (indent 2) (debug t)) (let ((fn-name (intern (concat "for-frame-type:" (if (symbolp name) (symbol-name name) name)))) (frame-sym (make-symbol "frame")) (predicate (cond ((memq type '(nil tty)) '(not window-system)) ((memq type '(t window-system)) 'window-system) ((symbolp type) (list 'eq 'window-system (list 'quote type))) ((not (consp type)) (signal 'wrong-type-argument (list 'symbol-or-cons-p 'type (cons :type type) (cons :name name) (cons :body body)))) ;; To exclude ttys, put `nil' in the list. ;; The special case (not . x) uses eq instead of memq; ;; but (not x) will still use memq. ((eq (car type) 'not) `(not (,(if (consp (cdr type)) 'memq 'eq) window-system (quote ,(cdr type))))) (t `(memq window-system (quote ,type)))))) `(disabling-buggy-dynamic-bytecode (defun ,fn-name (&optional ,frame-sym) (cond (,frame-sym) ; non-nil ;; emacs 19 ran after-make-frame-hook with no args, ;; but the new frame is let-bound to `nframe'. ((boundp 'nframe) (setq ,frame-sym nframe))) (save-current-frame (select-frame ,frame-sym) (save-window-excursion ;; select first window on frame so that `message' etc. use a ;; reasonable minibuffer window, and `display-buffer' etc. ;; create windows on the right frame. (select-window (frame-first-window ,frame-sym)) (when ,predicate ,@body)))) ;; Make hook run for all subsequently-created frames. ;; Emacs 19 did not have after-make-frame-functions. (if (boundp 'after-make-frame-functions) (add-hook 'after-make-frame-functions (quote ,fn-name)) (add-hook 'after-make-frame-hook (quote ,fn-name))) ;; Call new hook for all existing frames (let ((,frame-sym (frame-list))) (while ,frame-sym (,fn-name (car ,frame-sym)) (setq ,frame-sym (cdr ,frame-sym))))))) (defmacro for-window-system-frames (name &rest body) "NAME a BODY of expressions to be evaluated at frame creation time. These expressions will only be evaluated for window system frames. See `for-frame-type' for more details." (declare (indent 1)) `(for-frame-type window-system ,name ,@body)) (defmacro for-tty-frames (name &rest body) "NAME a BODY of expressions to be evaluated at frame creation time. These expressions will only be evaluated for console/tty frames. See `for-frame-type' for more details." (declare (indent 1)) `(for-frame-type tty ,name ,@body)) ;; Not especially meant to be used externally, but handles support for ;; older versions of emacs. (defmacro frame-fns::called-interactively-p (kind) (cond ((not (fboundp 'called-interactively-p)) (list 'interactive-p)) ((string-lessp emacs-version "23.2") ; 23.1 did not accept arg (list 'called-interactively-p)) (t `(called-interactively-p ,kind)))) (defun toggle-frame-parameter (frame param on off &optional force) "Toggle frame parameter PARAM just on frame FRAME. The value of ON and OFF correspond to the values of the frame parameter to be used for their respective states. Optional arg FORCE positive numeric argument means force on regardless of current state. If negative numeric argument or zero, force off regardless of current state." (declare (indent 1)) (let* ((cur (frame-parameter frame param)) (new (cond ((not (numberp force)) ;; includes default of nil (if (eq cur off) on off)) ((> force 0) on) (t off)))) (set-frame-parameter frame param new))) ;;;###autoload (defun toggle-frame-menu-bar-mode (&optional frame force) "Toggle the menu bar on the selected frame only. When called from lisp, optional positive numeric argument FORCE always sets state ON. A negative numeric argument sets state OFF." (interactive) (toggle-frame-parameter frame 'menu-bar-lines 1 0 force)) ;;;###autoload (defun toggle-frame-tool-bar-mode (&optional frame force) "Toggle the tool bar on the selected frame only. When called from lisp, optional positive numeric argument FORCE always sets state ON. A negative numeric argument sets state OFF." (interactive) (toggle-frame-parameter frame 'tool-bar-lines 1 0 force)) ;;;###autoload (defun toggle-frame-scroll-bar-mode (&optional frame force) "Toggle the vertical scroll bar on the selected frame only. When called from lisp, optional positive numeric argument FORCE always sets state ON. A negative numeric argument sets state OFF." (interactive) (toggle-frame-parameter frame 'vertical-scroll-bars default-frame-scroll-bars nil force)) ;;;###autoload (defun toggle-frame-horizontal-scroll-bar-mode (&optional frame force) "Toggle the horizontal scroll bar on the selected frame only. When called from lisp, optional positive numeric argument FORCE always sets state ON. A negative numeric argument sets state OFF." (interactive) (toggle-frame-parameter frame 'horizontal-scroll-bars t nil force)) ;;;###autoload (defun toggle-frame-fringe-mode (&optional frame force) "Toggle the fringes on the selected frame only. If fringes are toggle off, any prior frame-specific settings for the frame are lost. When fringes are toggled on again, they will use the global fringe style. When called from lisp, optional positive numeric argument FORCE always sets state ON. A negative numeric argument sets state OFF." (interactive) (let ((l (frame-parameter frame 'left-fringe)) (r (frame-parameter frame 'right-fringe))) (when (numberp force) (if (> force 0) (setq l 0 r 0) (setq l 1 r 1))) (if (not (and (zerop l) (zerop r))) (setq l 0 r 0) (cond ((numberp fringe-mode) (setq l (if (zerop fringe-mode) 8 fringe-mode) r l)) ((null fringe-mode) (setq l 8 r 8)) ((consp fringe-mode) (setq l (car fringe-mode) r (cdr fringe-mode))))) (set-frame-parameter frame 'left-fringe l) (set-frame-parameter frame 'right-fringe r))) ;;;###autoload (defun toggle-font-backend-order (&optional frame) "Switch the preferred font rendering backend for FRAME. If FRAME is nil, use the selected frame. Technically this function simply reverses the order of the backend list but there are usually at most two font rendering engines available for X Window frames: `x', the traditional X11 server-side engine, and a newer client-side engine like `xft' or `ftcrhb' (freetype/cairo/harfbuzz)." (interactive) (let ((fn (frame-parameter frame 'font)) (fb (frame-parameter frame 'font-backend))) ;; Emacs 27 and later will reset the default font (along with internal ;; face caches) when the backend order is changed. Restore the font we ;; were using previously. But, changing backends must be completed ;; before any further modifications are applied, so don't use ;; `modify-frame-parameters' to try to change both at once. (set-frame-parameter frame `font-backend (reverse fb)) (set-frame-parameter frame 'font fn))) ;; TODO: for the legacy case of manipulating wm hints directly, ;; update this once I finish writing the motif wm hint functions. ;; ;; TODO: This turns off all decorations. ;; Add commands to toggle just title bars or borders. (defun toggle-frame-wm-decoration (&optional frame force) "Request window manager to toggle decoration around FRAME's outer window. FRAME defaults to the selected frame. When called from lisp, optional positive numeric argument FORCE always sets state ON. A negative numeric argument sets state OFF." (interactive) (if (get 'undecorated 'x-frame-parameter) (toggle-frame-parameter frame 'undecorated nil t force) ;; Emacs 25 and earlier did not have the `decorated' frame param. (let* ((prop-name "_MOTIF_WM_HINTS") (prop-type prop-name) ;; the same, in this case (prop-val (or (frame-xprop frame prop-name prop-type) (vector 0 0 0 0 0))) (mwm-decor (aref prop-val 2))) (cond ((null force) (setq mwm-decor (logxor 1 mwm-decor))) ((> force 0) (setq mwm-decor (logior 1 mwm-decor))) ((< force 0) (setq mwm-decor (logand (lognot 1) mwm-decor)))) (aset prop-val 2 mwm-decor) ;; Indicate that decorations field is active (aset prop-val 0 (logior 2 (aref prop-val 0))) (set-frame-xprop frame prop-name prop-val prop-type))) (frame-wm-remap frame)) (defvar ffx-display-completions (make-vector 7 0) "Completion table for `ffx-display-complete'.") (defvar ffx-display-history nil "History of X server display names.") (defun ffx-display-complete (string predicate action) (if action (all-completions string ffx-display-completions predicate) (try-completion string ffx-display-completions predicate))) ;;;###autoload (defun ffx-display-add-completion (&rest displays) (declare (indent 0)) (interactive (list (completing-read "Add display completion: " 'ffx-display-complete nil nil nil 'ffx-display-history))) (while displays (intern (car displays) ffx-display-completions) (setq displays (cdr displays)))) (defun ffx-display-remove-completion (&rest displays) (declare (indent 0)) (interactive (list (completing-read "Remove display completion: " 'ffx-display-complete nil t nil 'ffx-display-history))) (while displays (unintern (car displays) ffx-display-completions) (setq displays (cdr displays)))) (defun ffx-display-completing-read (prompt &optional initial) (declare (indent 0)) (let ((disp (completing-read prompt 'ffx-display-complete nil nil initial 'ffx-display-history))) (ffx-display-add-completion disp) disp)) (defun ffx-font-name-completing-read (prompt &optional predicate require-match init hist) (declare (indent 0)) (let ((completion-ignore-case t) (completer (make-symbol "completer"))) (fset completer (lambda (str pred action) (let ((table (mapcar 'list (x-list-fonts (concat str "*"))))) (if action (all-completions str table pred) (try-completion str table pred))))) (completing-read prompt completer predicate require-match init hist))) ;; Some of this information can be obtained internally: ;; * x-display-visual-class returns visual information ;; * Depth can be obtained by x-display-planes ;; * WM_NORMAL_HINTS x property includes gravity ;; * In v25, x-frame-edges or x-frame-geometry will return the coordinate ;; information for various X window objects related to the frame. (defun frame-xwininfo (&optional frame) "Return an alist of X window attributes for frame FRAME. These attributes are generated from the output of the `xwininfo' command, since some values (e.g. the absolute location of frames including window manager decorations) cannot be determined from emacs primitives. If FRAME is not specified, the selected frame is the default." (with-temp-buffer (let ((id (or (frame-parameter frame 'parent-id) ;; non-nil = has wm (frame-parameter frame 'outer-window-id)))) (call-process "xwininfo" nil t nil "-display" (frame-parameter frame 'display) "-id" (format "%s" id))) (let ((case-fold-search t) (data nil) re start val) (mapc (lambda (param) (goto-char (point-min)) (setq re (concat "^[ \t]*" (cadr param) "[ \t]*")) (when (re-search-forward re nil t) (setq start (match-end 0)) (end-of-line) (save-restriction (narrow-to-region start (point)) (goto-char (point-min)) (setq val (buffer-substring start (if (re-search-forward "[ \t]+$" nil t) (match-beginning 0) (point-max))))) (if (string-match "^[0-9]+$" val) (setq val (string-to-number val))) (setq data (cons (cons (car param) val) data)))) '((abs-x "Absolute upper-left X:") (abs-y "Absolute upper-left Y:") (rel-x "Relative upper-left X:") (rel-y "Relative upper-left Y:") (width "Width:") (height "Height:") (depth "Depth:") (visual "Visual Class:") (border-width "Border width:") (class "Class:") (colormap "Colormap:") (bit-gravity "Bit Gravity State:") (window-gravity "Window Gravity State:") (backing-store "Backing Store State:") (save-under "Save Under State:") (map-state "Map State:") (override-redirect "Override Redirect State:") (corners "Corners:") (geometry "-geometry"))) (nreverse data)))) (defun ffx-set-frame-position (&optional frame xoff yoff) "Sets position of FRAME in pixels to XOFF by YOFF. This is actually the position of the upper left corner of the frame, including any window manager decorations. If either of XOFF or YOFF are nil, that coordinate is not changed. Negative values for XOFF or YOFF are interpreted relative to the rightmost or bottommost possible position that stays within the display. Values for XOFF or YOFF that are a list of the form (+ N) are interpreted to mean N pixels relative to top/left corner; A value of the form (- N) are interpreted to mean -N pixels relative to the bottom/right corner. For example, an xoff value of (+ -10) would place the left side of the frame 10 pixels off the edge of the left side of the display. A value of (- -10) would place the right edge of the frame 10 pixels off the edge of the rightmost edge of the display. To put the frame exactly at the bottom right corner, use the coordinates (- 0) (- 0)." (unless frame (setq frame (selected-frame))) (let* ((wininfo (frame-xwininfo frame)) (borders (* 2 (cdr (assq 'border-width wininfo)))) ;; fields are: offset, disp-dim, frame-dim, curpos, origin (xdata (vector xoff (x-display-pixel-width frame) (cdr (assq 'width wininfo)) (cdr (assq 'abs-x wininfo)) 0)) (ydata (vector yoff (x-display-pixel-height frame) (cdr (assq 'height wininfo)) (cdr (assq 'abs-y wininfo)) 0))) (mapc (lambda (vec) (let ((off (aref vec 0)) (origin (aref vec 4)) (delta (- (aref vec 1) (aref vec 2) borders))) (cond ((null off) (setq off (aref vec 3))) ((numberp off) (if (< off 0) (setq origin delta))) ((consp off) (cond ((eq '- (car off)) (setq origin delta off (- (nth 1 off)))) ((< (nth 1 off) 0) (setq origin (- delta) off (nth 1 off))) (t (setq off (nth 1 off)))))) (aset vec 0 off) (aset vec 4 origin))) (list xdata ydata)) (set-frame-position frame (+ (aref xdata 4) (aref xdata 0)) (+ (aref ydata 4) (aref ydata 0))))) (defun ffx-geometry-coord-add (coord delta) "Adjust positional coordinate COORD by DELTA amount. COORD is a coordinate in a form allowed by `ffx-set-frame-position'; that is, it may be either an integer or a list of the form (+/- N). DELTA must be an integer. " (cond ((numberp coord) ;; If result switches signs from coord, maintain corner-relativity. (let ((r (+ coord delta))) (if (< (* r coord) 0) (list (if (>= coord 0) '+ '-) r) r))) ((consp coord) (list (nth 0 coord) (+ (nth 1 coord) delta))))) (defun ffx-adjust-frame-position (frame x &optional y) (or frame (setq frame (selected-frame))) (or x (setq x 0)) (or y (setq y 0)) (let* ((fp (frame-parameters frame)) (xpos (cdr (assq 'left fp))) (ypos (cdr (assq 'top fp)))) (modify-frame-parameters frame (list (cons 'left (ffx-geometry-coord-add xpos x)) (cons 'top (ffx-geometry-coord-add ypos y)))))) (defun ffx-set-frame-geometry (frame geom) "Set FRAME to GEOM, specified as an X-style geometry string." (let* ((param (x-parse-geometry geom)) (x (assq 'left param)) (y (assq 'top param))) (if (or (and (numberp (cdr x)) (< (cdr x) 0)) (and (numberp (cdr y)) (< (cdr y) 0)) (and (consp (cdr x)) (eq '- (cadr x))) (and (consp (cdr y)) (eq '- (cadr y)))) (setq param (delq y (delq x param))) (setq x nil y nil)) (modify-frame-parameters frame param) (when (or x y) (sit-for 0) ;; redisplay frame so it can move (ffx-set-frame-position frame (cdr x) (cdr y))))) (defun ffx-frame-geometry-string (&optional frame &rest relative) "Return the geometry of the frame as an X-style geometry string. The string returned is in a form understood by `x-parse-geometry'." (let* ((fp (frame-parameters frame)) (disp (cdr (assq 'display fp))) (border (* 2 (cdr (assq 'border-width fp)))) (left (cdr (assq 'left fp))) (top (cdr (assq 'top fp)))) (when (numberp left) (setq left (list '+ left))) (when (memq 'right relative) (let* ((display-width (x-display-pixel-width disp)) (frame-width (+ border (frame-pixel-width frame))) (right-edge (ffx-geometry-coord-add left frame-width))) (setq left (ffx-geometry-coord-add (list '- display-width) (- (nth 1 right-edge)))))) (setq left (mapconcat (lambda (s) (format "%s" s)) left "")) (when (numberp top) (setq top (list '+ top))) (when (memq 'bottom relative) (let* ((display-height (x-display-pixel-height disp)) (frame-height (+ border (frame-pixel-height frame))) (bottom-edge (ffx-geometry-coord-add top frame-height))) (setq top (ffx-geometry-coord-add (list '- display-height) (- (nth 1 bottom-edge)))))) (setq top (mapconcat (lambda (s) (format "%s" s)) top "")) (format "%dx%d%s%s" (cdr (assq 'width fp)) (cdr (assq 'height fp)) left top))) (defun ffx-font-dimensions (font) "Return the average width and height, in pixels, of the font named FONT. The values are returned as a cons of the form \(width . height\). If the font name cannot be resolved, return nil." ;; Emacs 24 and earlier's font-info returns only 7-8 fields, and includes ;; no max or avg width information. But it does resolve font aliases of ;; the form "terminus8x14u", which, curiously, x-resolve-font-name does ;; not. So if font-info is defined, but doesn't return enough fields, ;; the first cond sets font to the resolved full name and evals to nil, ;; so that the subsequent cond will fill out the details. (cond ((and (fboundp 'font-info) (let ((info (font-info font))) (cond ((> (length info) 7) (cons (aref info 11) (aref info 3))) (info (setq font (aref info 1)) nil))))) ((fboundp 'x-decompose-font-name) (let* ((xlfd (x-decompose-font-name (x-resolve-font-name font))) (w (string-to-number (aref xlfd xlfd-regexp-avgwidth-subnum))) (h (string-to-number (aref xlfd xlfd-regexp-pixelsize-subnum)))) (cons (/ w 10) h))) (t ;; No lisp-accessible xlfd resolution in emacs 19. ;; Create an invisible frame, set the default font for it, then ;; read back the resolved font name from the frame parameters. ;; We don't bind delete-frame-functions etc. here because this ;; section is only run in emacs 19, which did not have those hooks. (let (tframe xlfd w h) (unwind-protect (progn (setq tframe (x-create-frame (list '(visibility . nil) (cons 'font font)))) (setq font (cdr (assq 'font (frame-parameters tframe))))) (and (framep tframe) (delete-frame tframe t))) (cond ((and font (consp (cdr (setq xlfd (string-split font "-"))))) (setq w (string-to-number (nth 12 xlfd)) h (string-to-number (nth 7 xlfd))) (cons (/ w 10) h))))))) (defun xrdb-symbols (&optional frame) "Return an alist of the cpp symbols and values defined by `xrdb' when \ compiling the X resource database. Optional arg FRAME may be a frame or display name; default is selected frame. The values returned may differ depending on which display or screen of the display is specified. Result members are of the form (SYMBOL VALUE), where VALUE may be nil. X extensions are also available as a list of symbols in the member `extensions'." (with-selected-display frame (let* ((case-fold-search nil) (s (with-command-output-to-string "xrdb" "-symbols" "-screen")) (defs (mapcar (lambda (elt) (split-string elt "=" t "\\\"")) (split-string s "\n" t "^-D"))) (ext) (result)) (mapc (lambda (elt) (when (string-match "^EXT_" (car elt)) (push (intern (substring (car elt) (match-end 0))) ext)) (when (and (> (length elt) 1) (string-match "^[0-9]+$" (nth 1 elt))) (setf (nth 1 elt) (string-to-number (nth 1 elt)))) (setcar elt (intern (car elt))) (push elt result)) defs) (nconc result (list (cons 'extensions ext))) result))) (defun xrdb-symbol-value (sym &optional syms-or-frame) "Return the value corresponding to SYM in the cpp symbols used by xrdb. Optional SYMS-OR-FRAME may be a frame, display name, or an alist of values already retrieved via `xrdb-symbols'. Some symbols do not have a value; they are merely defined. In that case, their presence can be checked instead with \t\(assq 'SYMBOL \(xrdb-symbols\)\)" (let ((alist (if (consp syms-or-frame) syms-or-frame (xrdb-symbols syms-or-frame)))) (nth 1 (assq sym alist)))) (defun frame-xprop-raw (frame prop &optional type window-id vector-ret-p) "Value is the value of window property PROP on FRAME. If FRAME is nil, use the selected frame. If FRAME is a number, get the property of that window id (which need not be an Emacs frame). The number 0 denotes the root window. Note that window ids are not unique if Emacs is connected to multiple displays. In that case, to get properties from the correct window id a frame on that display must be selected first. If FRAME is an actual frame, this is handled automatically. Optional arg WINDOW-ID is an alternate way to specify a specific window id. In that case, FRAME is only used for display context. Arg VECTOR-RET-P means convert numeric values from their binary representation. Usually use `frame-xprop' instead of setting this, since it does additional string parsing and error checking. This function is mostly a wrapper around `x-window-property'." (unless frame (setq frame (selected-frame))) (unless type (setq type "AnyPropertyType")) (setq prop (frame-symbol-to-xprop-name prop)) (with-selected-display (if (framep frame) frame) (let* ((id (cond (window-id) ((framep frame) (string-to-number (frame-parameter frame 'outer-window-id))) (t (prog1 frame (setq frame nil)))))) (x-window-property prop frame type id nil vector-ret-p)))) (defun frame-xprop (frame prop &optional type window-id) "Like `frame-xprop-raw', but always returns numeric vectors\ and splits any null-separated string result into a list. A few other bugs or misfeatures in Emacs' internals are corrected for as well." (save-match-data (let* ((result (frame-xprop-raw frame prop type window-id t)) (attr (if (fboundp 'x-window-property-attributes) (x-window-property-attributes prop (if (framep frame) frame) (cond (window-id) ((numberp frame) frame))))) (type (if attr (x-get-atom-name (aref attr 0)))) (format (if attr (aref attr 1)))) (cond ((and (stringp result) (eq 'STRING (get-text-property 0 'foreign-selection result)) (member type '("INTEGER" "CARDINAL")) ;; nil if no attrs (= format 8)) ;; if no attrs, this won't be eval'ed ;; Emacs will always return a string if format is 8, no matter ;; the actual type. So fix that here if we were able to fetch ;; attribute metadata. Without it, there's nothing we can do ;; about it here. (let ((fn (if (string= type "CARDINAL") 'identity (lambda (c) (if (> c 127) (- c 256) c))))) (apply 'vector (mapcar fn result)))) ((and (stringp result) (eq 'STRING (get-text-property 0 'foreign-selection result)) (string-match "\0" result)) (split-string result "\0" t)) (attr ;; If we were able to fetch property attributes, then emacs already does the ;; proper type conversion distinguishing CARDINAL and INTEGER ;; (these changes were introduced simultaneously) for formats ;; greater than 8, so we don't need to do any correction for ;; those. The format=8 case is handled above. result) ((and (numberp result) (< result 0) (or (null type) (not (string= type "INTEGER")))) ;; If result is a negative integer and we didn't explicitly ;; ask for integers, we must be on a 64-bit platform but emacs ;; has coerced a native long to a signed int. ;; (See xfns.c:x_window_property_intern in Emacs 25 and earlier) ;; Re-coerce it to an unsigned value. ;; Actually this is only correct for CARDINAL values. ;; But those are more common than INTEGER, and we have no way ;; in these versions of emacs to tell from lisp what the type is. (logand most-positive-fixnum result)) (t result))))) (defun set-frame-xprop (frame prop value &optional type format window-id) "This is a wrapper around `x-change-window-property', with some different defaults. If FRAME is nil, use the selected frame. Emacs 27 and later only: If FRAME is a number, set the property of that window id (which need not be an Emacs frame). The number 0 denotes the root window. Note that window ids are not unique if Emacs is connected to multiple displays or screens. In that case, to get properties from the correct window id a frame on that display must be selected first. If FRAME is an actual frame, this is handled automatically. Optional arg WINDOW-ID is an alternate way to specify a specific window id. In that case, FRAME is only used for display context. PROP may be a property name string or keyword. VALUE may be a string, vector, or list; vectors are converted to lists. If TYPE is non-nil, it is the name of the X atom that denotes the expected type. Otherwise, if value is a string, set the type as `STRING'. If value is a sequence of all positive numbers, set the type as `CARDINAL'. If any value is a negative number, set the type as `INTEGER'. FORMAT defaults to 32 if VALUE is a number, vector or list. It defaults to 8 if VALUE is a string. The property change is always applied to the outer X window of FRAME, when a frame object is modified and not just a numeric window id." (unless frame (setq frame (selected-frame))) (unless (and (framep frame) (null window-id)) (let* ((arglist (help-function-arglist 'x-change-window-property t)) (id-supported (and (consp arglist) (memq 'window-id arglist)))) (unless id-supported (signal 'wrong-type-argument "Numeric window-ids are not supported prior to Emacs 27")))) (with-selected-display (if (framep frame) frame) (let* ((id (cond (window-id) ((not (framep frame)) (prog1 frame (setq frame nil))))) (xval (cond ((vectorp value) (mapcar 'identity value)) ((numberp value) (cons value nil)) (t value))) (any-negative (catch 'negative (mapc (lambda (n) (if (and (numberp n) (< n 0)) (throw 'negative t))) xval))) (args (list (frame-symbol-to-xprop-name prop) xval frame (cond (type) ((stringp xval) "STRING") (any-negative "INTEGER") (t "CARDINAL")) (cond (format) ((stringp value) 8) (t 32)) 'outer-x-window))) (when id (nconc args (cons id nil))) (apply 'x-change-window-property args)))) (defun frame-symbol-to-xprop-name (prop) "Convert keywords like :wm-hints to \"WM_HINTS\"." (when (symbolp prop) (setq prop (upcase (symbol-name prop))) (save-match-data (when (string-match "^:" prop) (setq prop (substring prop 1)))) (let ((i 0) (n (length prop))) (while (< i n) (when (char-equal (aref prop i) ?-) (aset prop i ?_)) (setq i (1+ i))))) prop) ;; Internal function. Uses the fieldtbl vector passed in to parse values ;; in the propval vector into a meaningful alist. ;; It's possible this may only be useful for WM_HINTS and WM_NORMAL_HINTS. (defun frame-parse-field-prop (propval fieldtbl &rest specials-plist) (declare (indent 1)) (let* ((flags (aref propval 0)) (result)) (mapc (lambda (field) (unless (zerop (logand flags (lsh 1 (nth 1 field)))) (setq result (cons (cons (car field) (mapcar (lambda (n) (if (numberp n) (aref propval n) n)) (nthcdr 3 field))) result)))) fieldtbl) (while specials-plist (let ((elt (assq (car specials-plist) result))) (when elt (setcar (cdr elt) (aref (cadr specials-plist) (cadr elt))))) (setq specials-plist (cdr (cdr specials-plist)))) result)) ;; Modifies propval in-place in addiiton to returning it (defun frame-modify-field-prop (propval fieldtbl args &rest specials-plist) (declare (indent 3)) (let* ((flags (aref propval 0)) (field-name (car args)) (tbl (cdr (assq field-name fieldtbl))) (bit 0) (mask 0) (slots (nthcdr 2 tbl)) (subst (cadr (memq field-name specials-plist)))) (unless tbl (signal 'error (format "%s: unrecognized field" field-name))) (setq bit (lsh 1 (car tbl))) (mapc (lambda (b) (setq mask (logior mask b))) (cadr tbl)) (setq flags (logand (lognot mask) flags)) ; clear bit(s) (when args (setq flags (logior bit flags)) ; set bit (when subst ;; Replace symbolic value with its corresponding numeric one based ;; on its index in subst (let ((l (length subst)) (i 0) (val (cadr args))) (while (< i l) (cond ((eq val (aref subst i)) (setcar (cdr args) i) (setq i l)) (t (setq i (1+ i))))))) ;; Replace slots with given args (mapc (lambda (val) (if (numberp val) (aset propval (car slots) val)) (setq slots (cdr slots))) (cdr args))) (aset propval 0 flags) propval)) ;; elments are: type bit mask &rest fields (defconst frame-wm-normal-hints-field '((window-gravity 9 nil 17) ;; int or symbol (base-size 8 nil 15 16) ;; x y (max-aspect-ratio 7 nil 13 14) ;; x y (min-aspect-ratio 7 nil 11 12) ;; x y (resize-increment 6 nil 9 10) ;; x y (max-size 5 nil 7 8) ;; w h (min-size 4 nil 5 6) ;; w h (program-size 3 (1 3) 3 4) ;; w h (program-location 2 (0 2) 1 2) ;; x y (user-size 1 (1 3) 3 4) ;; w h (user-location 0 (0 2) 1 2))) ;; x y (defconst frame-wm-normal-hints-window-gravity [Forget NorthWest North NorthEast West Center East SouthWest South SouthEast Static]) (defun frame-wm-normal-hints (&optional frame) (frame-parse-field-prop (frame-xprop frame "WM_NORMAL_HINTS") frame-wm-normal-hints-field 'window-gravity frame-wm-normal-hints-window-gravity)) (defun set-frame-wm-normal-hint (frame &rest args) (let* ((hints (frame-xprop frame "WM_NORMAL_HINTS"))) (frame-modify-field-prop hints frame-wm-normal-hints-field args 'window-gravity frame-wm-normal-hints-window-gravity) (set-frame-xprop frame "WM_NORMAL_HINTS" hints "WM_SIZE_HINTS" 32))) ;; elments are: type bit mask &rest fields (defconst frame-wm-hints-field '((urgency 8 nil t) (leader-window-id 6 nil 8) (icon-mask-id 5 nil 7) (icon-position 4 nil 5 6) (icon-window-id 3 nil 4) (icon-bitmap-id 2 nil 3) (initial-state 1 nil 2) (accept-input 0 nil 1))) (defconst frame-wm-hints-initial-state [Nocare Normal Zoomed Iconified Inactive]) (defun frame-wm-hints (&optional frame) (frame-parse-field-prop (frame-xprop frame "WM_HINTS") frame-wm-hints-field 'initial-state frame-wm-hints-initial-state)) (defun set-frame-wm-hint (frame &rest args) (let* ((hints (frame-xprop frame "WM_HINTS"))) (frame-modify-field-prop hints frame-wm-hints-field args 'initial-state frame-wm-hints-initial-state) (set-frame-xprop frame "WM_HINTS" hints "WM_HINTS" 32))) (defun ffx-screen-display-name (screen &optional display) "Return display name for numbered SCREEN on DISPLAY. SCREEN may be an integer, string, or nil. If nil, just return existing display name. Otherwise, replace any existing screen number with SCREEN. Optional arg DISPLAY is an X server display name, a string. If nil, default to the display name of the currently selected frame." (unless display (setq display (frame-parameter (selected-frame) 'display))) (if (null screen) display (save-match-data (let* ((cur (matching-substring 1 display "\\(\\.[0-9.]+\\)$")) (beg (if (null cur) display (substring display 0 (- (length cur)))))) (format "%s.%s" beg screen))))) (defun ffx-atom-list (&optional frame beg end) "Return an alist of X server atom names to numbers on FRAME's display. If the `xlsatoms' command is not available, try to get atoms directly. Because this latter method is slow and `x-get-atom-name' doesn't distinguish between an undefined atom and one with an empty string value, there's no way to know when the list is complete. In that case, optional args BEG and END limit the range to scan. The default is 1 to 5000." (with-selected-display frame (condition-case nil (with-command-output-to-temp-buffer '("xlsatoms" "-f" "(%ld . \001%s\001)") (goto-char (point-min)) (while (re-search-forward "[\"\001]" nil t) (cond ((equal 1 (char-after (1- (point)))) (delete-char -1) (insert "\"")) ((equal 34 (char-after (1- (point)))) (backward-char 1) (insert "\\") (forward-char 1)))) (goto-char (point-max)) (insert ")") (goto-char (point-min)) (insert "(") (backward-char 1) (let ((alist (read (current-buffer)))) (mapc (lambda (c) (setcar c (prog1 (cdr c) (setcdr c (car c))))) alist) alist)) (file-error (unless beg (setq beg 1)) (unless end (setq end (+ beg 4999))) (let* ((n beg) (name nil) (tbl (cons nil nil)) (tail tbl)) (while (<= n end) (setq name (x-get-atom-name n)) (unless (equal name "") (setcdr tail (cons (cons name n) nil)) (setq tail (cdr tail))) (setq n (1+ n))) (cdr tbl)))))) ;; n.b. Emacs 19 frame parameters return top/left shifted by -1. ;; Emacs 21 returns top/left shifted by +1 ;; All others, including v20 (as of v25) are correct ;; The buggy two are too old to bother compensating for. (defun frame-wm-remap (&optional frame) "Unmap and re-map FRAME so that any new window manager hints will take effect. FRAME defaults to the selected frame if nil." (unless frame (setq frame (selected-frame))) (let* ((wm-state (frame-xprop frame "WM_STATE")) (parm (mapcar (lambda (p) (cons p (frame-parameter frame p))) '(visibility left top))) (vis (cdar parm)) (x (cdr (nth 1 parm))) (y (cdr (nth 2 parm)))) ;; Tell window manager hints where mapping is preferred. Emacs just ;; uses XMoveWindow, but doesn't set hints and the window manager may ;; ignore the window location when it gets a map notification otherwise. ;; We need to do this before unmapping the frame. (set-frame-wm-normal-hint frame 'user-location x y) (make-frame-invisible frame t) (make-frame-visible frame) (set-frame-xprop frame "WM_STATE" wm-state "WM_STATE") frame)) (defadvice delete-frame (around frame-fns:close-x-connection activate) "If deleting the last frame on an X display, query before closing the display." (interactive (list nil current-prefix-arg)) (let ((frame (or (ad-get-arg 0) (selected-frame)))) (cond ((and terminal-frame (eq frame terminal-frame)) (error "Do not close initial terminal frame; it will just hang.")) ((or (eq 'x (cdr (assq 'window-system (frame-parameters frame)))) (eq window-system 'x)) (let* ((primary-display (and (boundp 'x-display-name) (symbol-value 'x-display-name))) (display (or (cdr (assq 'display (frame-parameters frame))) primary-display)) (other-frames-on-display (filtered-frame-list (lambda (f) (and (not (eq f frame)) (string= display (or (cdr (assq 'display (frame-parameters f))) ""))))))) (cond ((null display)) ((and (null other-frames-on-display) (not (y-or-n-p (concat "Close connection to X server " display "? "))))) (t (prog1 ad-do-it (and (not (frame-live-p frame)) (null other-frames-on-display) (stringp primary-display) ;; Closing the x connection to the original display can ;; crash some versions of emacs. (not (string= display primary-display)) (x-close-connection display))))))) (t ad-do-it)))) (defadvice make-frame-on-display (before frame-fns:histcomplete activate) "Provide completion and history on previously-seen display names." (interactive (list (ffx-display-completing-read "Make frame on display: ")))) ;;;###autoload (defun other-frame-absolute (arg) "Like other-frame, but don't skip over non-visible frames. If the target frame is not visible, make it visible." (interactive "p") (let ((frame (selected-frame))) (while (> arg 0) (setq frame (next-frame frame)) (setq arg (1- arg))) (while (< arg 0) (setq frame (previous-frame frame)) (setq arg (1+ arg))) (raise-frame frame) (select-frame frame) (set-mouse-position (selected-frame) (1- (frame-width)) 0) (and (fboundp 'unfocus-frame) (unfocus-frame)))) ;;;###autoload (defun set-basic-frame-color (color &optional frame fringe-full-brightness-p) (interactive "sColor: ") (or frame (setq frame (selected-frame))) (cond ((facep 'fringe) ;; Emacs 21. Set specific faces, otherwise other faces are trashed. (set-face-foreground 'fringe (if fringe-full-brightness-p color (make-less-bright-color color 2 frame)) frame) (set-face-foreground 'default color frame) (set-face-foreground 'mode-line color frame) (set-face-background 'cursor color frame) (set-face-background 'mouse color frame)) (t ;; Emacs 20 and earlier. (save-current-frame (select-frame frame) (set-foreground-color color) (set-cursor-color color) (set-mouse-color color))))) ;;;###autoload (defun set-frame-titles (title &optional frame) "Set the icon and window titles of frame FRAME to TITLE. If called interactively or no frame is specified in a function call, the selected frame is modified." (interactive "sSet selected frame title: ") (modify-frame-parameters (or frame (selected-frame)) (mapcar (lambda (key) (cons key title)) '(name title icon-name)))) ;;;###autoload (defun set-default-frame-title (title) "Set the default icon and window titles of future frames to TITLE." (interactive "sSet default frame title: ") (let ((syms '(name title icon-name))) (while syms (set-alist-slot 'default-frame-alist (car syms) title) (setq syms (cdr syms))))) ;;;###autoload (defun set-display (&optional disp) "Set DISPLAY environment variable. If argument is nil or \"\", unset variable." (interactive (list (let ((s (cond ((getenv "DISPLAY")) ((eq window-system 'x) (cdr (assq 'display (frame-parameters)))) (t ":0.0")))) (ffx-display-completing-read "DISPLAY = " (cons s 0))))) (and (string= disp "") (setq disp nil)) (setenv "DISPLAY" disp)) ;;;###autoload (defun set-cursor-type (&optional frame type height-or-width) "Set default cursor type for current frame. If the current buffer has a local value for `cursor-type', the new cursor type may not be visible there." (interactive (list nil (completing-read "Cursor type (default `box'): " '((box) (hollow) (nil) (bar) (hbar)) nil t nil nil "box") (when current-prefix-arg (read-number "Size in pixels: " 2)))) (when (stringp type) (setq type (intern type))) (when (and (memq type '(bar hbar)) height-or-width) (setq type (cons type height-or-width))) (modify-frame-parameters frame `((cursor-type . ,type)))) ;; Unicode says that the characters U+0060 and U+0027 are a grave accent ;; and a vertical quote, not an open and close quotation mark. The XFree86 ;; (and X.org Foundation) 4.x fonts display these characters accordingly. ;; However, GNU documentation (info and doc strings) use them as open and ;; close quotation marks (a holdover from ascii days and display terminals ;; where these characters appeared balanced). ;; ;; The emacs development source for 21.5 (later renamed to 22.0) was ;; briefly changed to use U+2018 and U+2019 character glyphs (these come ;; from iso10646 fonts) for display of U+0060 and U+0027 in the ;; "standard-display-european" display table, but consensus was that this ;; was a bad idea. ;; ;; Ken'ichi HANDA wrote on emacs-devel: ;; ;; I think `' should not be displayed by U+2018 and U+2019. Unicode ;; defines them not as balanced quotes. Using them as balanced quotes ;; is abuse of characters as far as we follow Unicode. ;; ;; Considering the long standing convention, I don't suggest to stop ;; this abuse. But, at least, we should not disturb people who use ;; those characters correctly in the sense of Unicode by displaying ;; them with characters of different semantics. ;; ;; I agree. However I am choosing to abuse the display for myself privately. ;; ;; More details about quotes at: http://www.cl.cam.ac.uk/~mgk25/ucs/quotes.html (defun display-balanced-single-quotes (&optional prefix) "Replace display of iso8859-1 ` \(0x60\) and ' \(0x27\) characters with symmetric glyphs. On window-systems frames, these characters are replaced with the glyphs from iso10646 U+2018 and U+2019, respectively. On tty frames, ' \(0x27\) is replaced with \264 (0xb4), which is usually symmetric with ` \(0x60\). This command works by modifying `standard-display-table' \(which see\); if the version of emacs in use supports simultaneous X and tty frames, consider first making `standard-display-table' frame-local with `make-standard-display-table-frame-local'. With positive prefix arg, enable glyph replacement. With negative prefix arg, restore display to original glyphs. Otherwise, toggle current display." (interactive "P") (and (consp prefix) (setq prefix (car prefix))) (cond ((or (null prefix) (equal prefix 0)) (setq prefix 'toggle)) ((and (numberp prefix) (> prefix 0)) (setq prefix t)) (t (setq prefix nil))) (let ((tbl standard-display-table)) (cond ((not window-system) ;; On character terminals, just try to make the vertical quote ;; match the slanted backquote. (if (or (eq prefix t) (and (eq prefix 'toggle) (null (aref tbl ?')))) (aset tbl ?' [?\xb4]) (aset tbl ?' nil))) ((and (eq window-system 'x) (fboundp 'decode-char) ; FSF v21 (member (downcase (x-server-vendor)) '("fedora project" "the xfree86 project, inc" "the x.org foundation")) (or (> (nth 2 (x-server-version)) 10300000) (> (aref (number-to-string (nth 2 (x-server-version))) 0) ?3))) (cond ((or (eq prefix t) (and (eq prefix 'toggle) (null (aref tbl ?')))) (aset tbl ?' (vector (decode-char 'ucs ?\x2019))) (aset tbl ?` (vector (decode-char 'ucs ?\x2018)))) (t (aset tbl ?' nil) (aset tbl ?` nil))))) (when (frame-fns::called-interactively-p 'interactive) (message "balanced quote glyphs %s" (if (aref tbl ?') "enabled" "disabled")))) prefix) ;; Emacs 26 no longer supports frame-local variables directly. These ;; primitives allow one to declare, set, and retrieve frame-local ;; variables at a lisp level, though it must be done explicitly. ;; As the semantics do not match buffer-local (or the prior frame-local) ;; variables exactly, use "specific" rather than "local" here to distinguish. (defun make-variable-frame-specific (var) "Enable VAR, a symbol, to have frame-specific bindings. This simply sets a property on the symbol so that `frame-specific-value' and `set-frame-specific-value' functions know to examine or modify the frame parameters for the current or a specified frame before buffer-local or global variables. Roughly analogous to frame-local variables in Emacs 21, but they must be inspected explicitly since later versoins of Emacs no longer officially support them and in Emacs 26 the frame-local primitives were removed entirely." (put var 'frame-specific t)) (defun frame-specific-variable-p (var) "True if var is a symbol that has been marked by `make-variable-frame-specific'." (get var 'frame-specific)) (defun frame-specific-value (var &optional frame) "Return the frame-specific value for VAR on FRAME, if any. If FRAME is nil, use selected frame. If VAR is not a frame-specific variable or FRAME does not have one, use the global variable instead." (let ((elt (assq var (frame-parameters frame)))) (if elt (cdr elt) (symbol-value var)))) (defun set-frame-specific-value (var value &optional frame) "Set frame-specific value for VAR to VALUE on FRAME. If FRAME is nil, use selected frame." (set-frame-parameter frame var value)) ;; There is no adequate replacement for these in Emacs 26. ;; TODO: investigate window-configuration-change-hook as a possible means ;; to set the display table for new windows using set-window-display-table. (defun make-standard-display-table-frame-local () "Make all current and future frames have a frame-local standard-display-table. Frames with the same window-system type e.g. `x', `nil' (for tty), share the same display table." (declare (obsolete "frame-local variables are no longer supported" "26.0")) (require 'disp-table) ; make sure standard-display-table initialized (make-variable-frame-local 'standard-display-table) (add-hook 'after-make-frame-functions 'set-frame-type-local-standard-display-table) (mapc 'set-frame-type-local-standard-display-table (frame-list))) (defun set-frame-type-local-standard-display-table (&optional frame) "Initialize FRAME with the proper frame-local standard-display-table." (declare (obsolete "frame-local variables are no longer supported" "26.0")) (or frame (setq frame (selected-frame))) (modify-frame-parameters frame (list (cons 'standard-display-table (frame-type-local-standard-display-table frame t t))))) (defun frame-type-local-standard-display-table (frame-type &optional createp copy-default-p) "Return the standard-display-table for frames of type FRAME-TYPE. If FRAME-TYPE is a frame object, return the table for window-system type of that frame. Optional argument CREATEP means create a new standard-display-table for frames of that type if none exists yet. Optional argument COPY-DEFAULT-P means start the new table with a full copy of the global standard-display-table \(if any\)." (declare (obsolete "frame-local variables are no longer supported" "26.0")) (when (or (null frame-type) (framep frame-type)) (setq frame-type (frame-display-type frame-type))) (let ((tbl (get 'standard-display-table frame-type))) (cond (tbl) (createp ; no tbl yet (if (and copy-default-p (default-boundp 'standard-display-table) (char-table-p (default-value 'standard-display-table))) (setq tbl (copy-char-table (default-value 'standard-display-table))) (setq tbl (make-display-table)) (put 'standard-display-table frame-type tbl)))) (or tbl standard-display-table))) (defun frame-display-type (&optional frame) "Return the window-system type for FRAME, or `tty' if not on a window system." (or frame (setq frame (selected-frame))) ;; Handle case where window-system is frame-local because ;; there are both tty and x frames. We have to check that ;; the variable is actually in the frame-parameter alist; a ;; nil result from `frame-parameter' wouldn't be ;; distinguishable from the spec for a tty frame. (cond ((let ((cell (assq 'window-system (frame-parameters frame)))) (when cell (or (cdr cell) 'tty)))) ;; Otherwise, nil means tty frame ;; Don't let buffer-local vars shadow value (t (or (default-value 'window-system) 'tty)))) (defun copy-char-table (table) "Make a full copy of char-table TABLE. All slots, including table subtype and extra slots, are copied. If any of the slots is a symbol, the value of that symbol is not copied." (let* ((type (char-table-subtype table)) (new (make-char-table type)) (extra-slots (get type 'char-table-extra-slots)) (slot 0)) (map-char-table (lambda (range val) (set-char-table-range new range val)) table) (while (< slot extra-slots) (set-char-table-extra-slot new slot (char-table-extra-slot table slot)) (setq slot (1+ slot))) new)) ;;;###autoload (defun switch-to-empty-buffer () "Switch current window to a read-only buffer with no contents." (interactive) (switch-to-buffer " *empty*") (fundamental-mode) (setq default-directory "~/") (and (fboundp 'protect-buffer-from-kill-mode) (protect-buffer-from-kill-mode 1)) (setq buffer-read-only t) (current-buffer)) ;;;###autoload (defun empty-other-frames (&optional preserved-frame) "Insure that no other frames display any buffers. The purpose of this is twofold: first, it prevents `other-buffer' from skipping buffers in the current frame's buffer list just because they may be visible in some other frame; secondly, it reduces the potential for redisplay on remote frames, which might freeze emacs when a network connection is down or slow at a later point in time. If escreen is enabled, non-trivial window configurations are saved and a new escreen is created; or if an escreen already exists with just the empty buffer in a single window, that escreen will be selected. This function uses `switch-to-empty-buffer' to alter the window buffers." (interactive) (mapc (lambda (frame) (let ((wlist (window-list frame 'never-minibuf (frame-first-window frame)))) (cond ((and (null (cdr wlist)) ; only 1 window (not (window-dedicated-p (car wlist)))) (save-window-excursion (select-window (car wlist)) (switch-to-empty-buffer))) ;; If escreens are in use and the current screen wasn't a ;; one-window screen altered above, then search all the ;; screens on this frame to see if there are any which ;; already have just one window with the empty buffer. ;; If so, switch to it. Otherwise, create a new screen ;; so that nontrivial window configurations are not lost. ((fboundp 'escreen-create-screen) (save-current-frame (select-frame frame) ;; update screen map now so we have accurate data; ;; normally only updated when switching screens. (escreen-save-current-screen-configuration) (let ((screens (escreen-get-active-screen-numbers)) screen-window-map) (while (consp screens) (setq screen-window-map (escreen-configuration-data-map (escreen-configuration-escreen (car screens)))) (cond ((and (null (cdr screen-window-map)) ; 1 window (string= ;; name of buffer in that window (escreen-configuration-data-map-critical-buffer-name (escreen-configuration-data-map-critical (car screen-window-map))) " *empty*")) (escreen-goto-screen (car screens)) (setq screens t)) (t (setq screens (cdr screens))))) (unless (eq screens t) (escreen-create-screen) (switch-to-empty-buffer))))) (t (save-window-excursion (select-window (car wlist)) (delete-other-windows) ;; Is this a good idea? If the window is dedicated, ;; perhaps it shouldn't be deleted. ;; To hell with it. If it's that important, use escreen. (when (window-dedicated-p (selected-window)) (select-window (split-window)) (delete-other-windows)) (switch-to-empty-buffer)))))) (delq (or preserved-frame (selected-frame)) (frame-list)))) ;; This makes use of locally bound variables in `make-large-simple-frame'. ;; The cdr of each elt is a form to be called via eval. (defconst make-large-simple-frame-fontset-alist '((default (cond ((> display-height 1200) "-misc-fixed-medium-r-normal-*-20-*-*-*-*-100-iso10646-1") ;; 10x20 ((>= display-height 1024) "-misc-fixed-medium-r-normal-*-15-*-*-*-*-90-iso10646-1") ;; 9x15 (t "-misc-fixed-medium-r-semicondensed-*-13-*-*-*-*-60-iso10646-1"))) ;; 6x13 (terminus (cond ((> display-height 1200) "-xos4-terminus-medium-r-normal-*-20-*-*-*-*-*-iso10646-1") ;; 10x20 ((>= display-height 1024) "-xos4-terminus-medium-r-normal-*-14-*-*-*-*-*-iso10646-1") ;; 8x14 (t "-xos4-terminus-medium-r-normal-*-12-*-*-*-*-*-iso10646-1"))))) ;; 6x12 (defvar make-large-simple-frame-fontset 'default) (defvar make-frame-with-geometry-use-lsf-fontset nil "*If non-nil, `make-frame-with-geometry' uses \ `make-large-simple-frame-fontset-font' when optional params do not specify \ a font already. When nil, do not add any font parameter.") (defun make-large-simple-frame-fontset-form (&optional fontset frame) (unless fontset (setq fontset (frame-specific-value 'make-large-simple-frame-fontset frame))) (let* ((alist make-large-simple-frame-fontset-alist) (elt (or (assq fontset alist) (assq 'default alist)))) (car (cdr elt)))) (defun make-large-simple-frame-fontset-font (&optional fontset display) (let* ((display-height (x-display-pixel-height display)) (display-width (x-display-pixel-width display)) (fs (make-large-simple-frame-fontset-form fontset)) (fontpat (eval fs)) (font (car (x-list-fonts fontpat)))) font)) (defun large-simple-frame-setup (frame &optional color) (when (fboundp 'set-fringe-style) (save-current-frame (select-frame frame) (set-fringe-style fringe-mode))) ;; If the frame was created with the title "notitle" to keep the window ;; manager from putting a title bar on it, change it to something more ;; meaningful now that the frame exists. (when (string= (or (frame-parameter frame 'title) "") "notitle") (set-frame-titles (format "emacs@%s" (system-name)) frame)) (set-basic-frame-color (or color "white") frame) (mapc (lambda (elt) (set-face-foreground (car elt) "white" frame) (set-face-background (car elt) (cadr elt) frame)) '((highlight "black") (region "blue") (secondary-selection "darkslateblue"))) frame) ;;;###autoload (defun make-large-simple-frame (&optional width height x-offset y-offset title color display font) "Create a large frame free of most GUI elements (menus, toolbars, etc). If optional parameters WIDTH or HEIGHT are not specified, create a frame occupying as much horizontal and/or vertical space as possible. If optional arg FONT is not specified, use a font from the fontset specified by `make-large-simple-frame-fontset', which should be set to a value corresponding to one of the slots in `make-large-simple-frame-fontset-alist' (which see). If X-OFFSET is positive, create frame on display with that offset in pixels from the left edge of the display. If offset is negative, offset the frame from the right edge of the display. Y-OFFSET treated similarly for top and bottom edges. If TITLE is non-nil, use the title \"notitle\" during initial frame creation; it is reset later. The user's window manager can be configured not to put a title bar across the top of the window when this title name is chosen; otherwise there should be no effect. Optional arguments COLOR and DISPLAY specify the frame color for most attributes (text, mode line, mouse, cursor) and the X display, respectively." (declare (indent 0)) (interactive (when current-prefix-arg (list nil nil nil nil nil nil nil (ffx-font-name-completing-read "Frame font: ")))) (let* (;; Emacs 24 applies any values from default-frame-alist that are ;; missing from the explicit parameters here; we don't want any of ;; those, so shadow this to nil. (default-frame-alist nil) (font (if font (or (car (x-list-fonts font)) ;; nil unless xlfd/fc/gtk name font) (make-large-simple-frame-fontset-font nil display))) (font-dim (ffx-font-dimensions font)) (border-width (or (assq 'border-width default-frame-alist) 1)) (display-height (x-display-pixel-height display)) (display-width (x-display-pixel-width display)) (frame-height (or height (/ (- display-height (* 2 border-width)) (cdr font-dim)))) ;; The fringe is an Emacs 21 window region. Starting with v22 we ;; can handle this in a more accurate way so we use 0 here and ;; adjust later. (fringe-width (cond ((not (facep 'fringe)) 0) ; pre-21 ((fboundp 'set-fringe-style) 0) ; v22 (t (* 2 (car font-dim))))) (frame-width (or width (/ (- display-width (* 2 border-width) fringe-width) (car font-dim)))) (h-offset (cond ((null x-offset) (setq x-offset 0)) ((< x-offset 0) (setq x-offset (- display-width ;; frame width in pixels (* (car font-dim) frame-width) fringe-width (* 2 border-width) (- x-offset)))) (t x-offset))) (v-offset (cond ((null y-offset) (setq y-offset 0)) ((< y-offset 0) (setq y-offset (- display-height ;; frame height in pixels (* (cdr font-dim) frame-height) (* 2 border-width) (- y-offset)))) (t y-offset))) (frame-title (cond ((null title) "notitle") ((symbolp title) (cdr (assq 'name default-frame-alist))) (t title))) (frame-params `((name . ,frame-title) (icon-name . ,frame-title) (title . ,frame-title) (font . ,font) (menu-bar-lines . 0) (tool-bar-lines . 0) (vertical-scroll-bars . nil) (width . ,frame-width) (height . ,frame-height) (left . ,h-offset) (top . ,v-offset) (border-color . "black") ,@(if (fboundp 'set-fringe-style) '((right-fringe . 0) (left-fringe . 0))))) frame) (setq frame (if display (make-frame-on-display display frame-params) (make-frame frame-params))) (large-simple-frame-setup frame color) (when (and (zerop x-offset) (zerop y-offset)) (set-frame-position frame 0 0)) frame)) (defun make-frame-with-geometry (geomstr &optional params) "Make frame with size and location specified by GEOMSTR, an X geometry string. Optional args PARAMS are additional parameters to `make-frame'. Positional coordinates take window manager decoration (borders, titles, etc) into account by way of `ffx-set-frame-position', so this function is potentially more accorate than calling `make-frame' directly." (declare (indent 1)) (let* ((have-wm-p (frame-parameter (selected-frame) 'parent-id)) (geom (x-parse-geometry geomstr)) (xpos (cdr (assq 'left geom))) (ypos (cdr (assq 'top geom))) (pvis (cdr (assq 'visibility params))) (disp (cdr (assq 'display params))) (font (when (and make-frame-with-geometry-use-lsf-fontset (null (assq 'font params))) (list (cons 'font (make-large-simple-frame-fontset-font nil disp))))) (frame (make-frame (append '((visibility . icon) (wait-for-wm . t) (user-position . t)) geom font params)))) (sit-for 0) ;; redisplay new frame so it can move ;; If an existing frame has a window manager, wait until the wm ;; reparents the new frame. (when have-wm-p (while (null (frame-parameter frame 'parent-id)) (sleep-for .1))) (when (or xpos ypos) (ffx-set-frame-position frame xpos ypos)) (set-frame-parameter frame 'visibility (or pvis t)) frame)) ;; Not sure if these belong here, but what the hell. ;;;###autoload (defun make-aaa-frame (&optional name frame-params) "Make a frame that resembles an Ann Arbor Ambassador portrait mode display." (interactive (list (and current-prefix-arg (read-string "Frame name: ")))) (or name (setq name (cdr (assq 'name default-frame-alist)))) (let* ((font (make-large-simple-frame-fontset-font)) (params `((name . ,name) (icon-name . ,name) (title . ,name) (font . ,font) (menu-bar-lines . 0) (tool-bar-lines . 0) (vertical-scroll-bars . nil) (left-fringe . 0) ;; Until there is some way to put the ascii `\' ;; continuation char back on X frames, the right-fringe ;; is needed. ;;(right-fringe . 0) (cursor-type . hbar) (width . 80) (height . 60) (border-color . "black") (background-color . "black"))) frame) (while frame-params (set-alist-slot params (car (car frame-params)) (cdr (car frame-params))) (setq frame-params (cdr frame-params))) (setq frame (make-frame params)) (mapc (lambda (face) (set-face-foreground (car face) "green" frame) (set-face-background (car face) "black" frame)) (frame-face-alist frame)) ;; Now fix up some of the faces to be more sensible, e.g. flipping fg/bg (set-basic-frame-color "green" frame) frame)) ;;;###autoload (defun make-frobbity-frame (&optional name) "Make a frame with menu bar, scroll bars, etc." (interactive (list (and current-prefix-arg (read-string "Frame name: ")))) (or name (setq name (cdr (assq 'name default-frame-alist)))) (make-frame `((name . ,name) (icon-name . ,name) (title . ,name) (menu-bar-lines . 1) (tool-bar-lines . 3) (vertical-scroll-bars . t)))) (provide 'frame-fns) ;;; frame-fns.el ends here.