;;; frame-fns.el --- frame manipulation commands ;; Copyright (C) 1992-1997, 1999, 2000 Noah S. Friedman ;; Author: Noah Friedman ;; Maintainer: friedman@splode.com ;; $Id: frame-fns.el,v 1.8 2000/03/03 08:54:42 friedman Exp $ ;; This program 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. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, you can either send email to this ;; program's maintainer or write to: The Free Software Foundation, ;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA. ;;; Commentary: ;;; Code: (require 'list-fns) (defvar x-display-completions (make-vector 7 0) "Completion table for `x-display-complete'.") (defvar x-display-history nil "History of X server display names.") (defadvice delete-frame (around close-x-connection activate) "If deleting the last frame on a display, query before closing the display." (interactive (list nil current-prefix-arg)) (let* ((frame (or (ad-get-arg 0) (selected-frame))) (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 (function (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 emacs. (not (string= display primary-display)) (x-close-connection display))))))) ;;;###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: ")))) (let ((params (copy-alist default-frame-alist))) (cond (name (set-alist-slot params 'name name) (set-alist-slot params 'icon-name name) (set-alist-slot params 'title name))) (set-alist-slot params 'font "fixed") (set-alist-slot params 'menu-bar-lines 0) (set-alist-slot params 'vertical-scroll-bars nil) (set-alist-slot params 'width 80) (set-alist-slot params 'height 60) (set-alist-slot params 'mouse-color "green") (set-alist-slot params 'cursor-color "green") (set-alist-slot params 'border-color "black") (set-alist-slot params 'foreground-color "green") (set-alist-slot params 'background-color "black") (while frame-params (set-alist-slot params (car (car frame-params)) (cdr (car frame-params))) (setq frame-params (cdr frame-params))) (make-frame params))) (defadvice make-frame-on-display (before histcomplete activate) "Provide completion and history on previously-seen display names." (interactive (list (x-display-completing-read "Make frame on display: ")))) ;;;###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: ")))) (let ((params (copy-alist default-frame-alist))) (cond (name (set-alist-slot params 'name name) (set-alist-slot params 'icon-name name) (set-alist-slot params 'title name))) (set-alist-slot params 'menu-bar-lines 1) (set-alist-slot params 'vertical-scroll-bars t) (make-frame params))) ;;;###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) (interactive "sColor: ") (cond ((facep 'fringe) ;; Emacs 21. Set specific faces, otherwise other faces are trashed. (set-face-foreground 'default color (selected-frame)) (set-face-foreground 'fringe color (selected-frame)) (set-face-foreground 'mode-line color (selected-frame)) (set-face-background 'cursor color (selected-frame)) (set-face-background 'mouse color (selected-frame))) (t ;; Emacs 20 and earlier. (set-foreground-color color) (set-cursor-color color) (set-mouse-color color)))) ;;;###autoload (defun set-selected-frame-title (title) (interactive "sSet current frame title: ") (modify-frame-parameters (selected-frame) (mapcar (function (lambda (key) (cons key title))) '(name title icon-name)))) ;;;###autoload (defun set-default-frame-title (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")))) (x-display-completing-read "DISPLAY = " (cons s 0))))) (and (string= disp "") (setq disp nil)) (setenv "DISPLAY" disp)) ;;;###autoload (defun toggle-frame-cursor-type (&optional prefix frame) "Toggle between `box' and `bar' cursor types on frame. With positive prefix argument, always set `box' cursor type. With negative prefix argument, always set `bar' cursor type." (interactive "p") (let ((new (cond ((or (null prefix) (zerop prefix) (= prefix 1)) (cdr (assq (cdr (assq 'cursor-type (frame-parameters frame))) '((box . bar) (bar . box))))) ((> prefix 1) 'box) ((< prefix 0) 'bar)))) (modify-frame-parameters (or frame (selected-frame)) (list (cons 'cursor-type new))))) (defun x-display-complete (string predicate action) (if action (all-completions string x-display-completions predicate) (try-completion string x-display-completions predicate))) (defun x-display-add-completion (&rest displays) (while displays (intern (car displays) x-display-completions) (setq displays (cdr displays)))) (defun x-display-completing-read (prompt &optional initial) (let ((disp (completing-read prompt 'x-display-complete nil nil initial 'x-display-history))) (x-display-add-completion disp) disp)) (provide 'frame-fns) ;;; frame-fns.el ends here.