;;; xterm-frobs.el --- manipulate xterm when running emacs in tty mode

;; Copyright (C) 1998, 1999 Noah S. Friedman

;; Author: Noah Friedman <friedman@splode.com>
;; Maintainer: friedman@splode.com
;; Created: 1998-03-21

;; $Id: xterm-frobs.el,v 1.4 2000/02/02 03:08:05 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:

;; Commands for tty-mode emacs when running under xterm, to manipulate the
;; parent xterm state.  Some of these commands may only work with post-1996
;; XFree86 xterm versions.

;; Updates of this program may be available via the URL
;; http://www.splode.com/~friedman/software/emacs-lisp/

;;; Code:

;; If non-nil, this value should be a string which is used to perform
;; Device Control String encapsulation of any escape sequence sent to the
;; terminal.  For example, if emacs is running under the `screen' tty
;; session management program (which does its own terminal emulation), the
;; sequence sent to the terminal must be wrapped in a DCS so that the
;; original control sequence will be passed uninterpreted to the parent
;; xterm.
(defvar xterm-dcs-encapsulation
  (cond ((or (getenv "STY")
             (member (getenv "TERM") '("screen" "screen-w" "screen-60")))
         "\eP%s\e\\")))

(defun xterm-iconify ()
  "Minimize \(iconify\) xterm window."
  (interactive)
  (xterm-send-escape-sequence "\e[2t"))

(defun xterm-deiconify ()
  "Restore \(deiconify\) xterm window."
  (interactive)
  (xterm-send-escape-sequence "\e[1t"))


(defun xterm-set-font (font-name)
    "Set the font of the xterm window to FONT.
When called interactively, prompt for the name of the font to use.

This function is used to change the font of the xterm window in which a
tty-mode emacs is running.  It should also work if emacs is running under
`screen' in an xterm window.

Use \\[set-default-font] if this emacs is using the window system directly."
  (interactive "sFont name: ")
  (xterm-send-escape-sequence (format "\e]50;%s\a" font-name)))

(defun xterm-set-icon-title (title)
  "Set the title in the icon for this xterm window to TITLE.
This does not change the title of the corresponding window."
  (interactive "sIcon title: ")
  (xterm-send-escape-sequence (format "\e]1;%s\a" title)))

(defun xterm-set-window-title (title)
  "Set the title for xterm window to TITLE.
This does not change the title in the corresponding icon."
  (interactive "sWindow title: ")
  (xterm-send-escape-sequence (format "\e]2;%s\a" title)))

(defun xterm-set-all-titles (title)
  "Set the title for xterm window and corresponding icon to TITLE."
  (interactive "sIcon and window title: ")
  (xterm-send-escape-sequence (format "\e]0;%s\a" title)))


(defun xterm-set-background-color (color)
  (interactive "sBackground color: ")
  (xterm-send-escape-sequence (format "\e]10;%s\a" color)))

(defun xterm-set-foreground-color (color)
  (interactive "sForeground color: ")
  (xterm-send-escape-sequence (format "\e]11;%s\a" color)))

(defun xterm-set-cursor-color (color)
  (interactive "sCursor color: ")
  (xterm-send-escape-sequence (format "\e]12;%s\a" color)))

(defun xterm-set-mouse-foreground-color (color)
  (interactive "sMouse foreground color: ")
  (xterm-send-escape-sequence (format "\e]13;%s\a" color)))

(defun xterm-set-mouse-background-color (color)
  (interactive "sMouse background color: ")
  (xterm-send-escape-sequence (format "\e]14;%s\a" color)))

(defun xterm-set-Tek-foreground-color (color)
  (interactive "sTek foreground color: ")
  (xterm-send-escape-sequence (format "\e]15;%s\a" color)))

(defun xterm-set-Tek-background-color (color)
  (interactive "sTek background color: ")
  (xterm-send-escape-sequence (format "\e]16;%s\a" color)))

(defun xterm-set-highlight-color (color)
  (interactive "sHighlight color: ")
  (xterm-send-escape-sequence (format "\e]17;%s\a" color)))

(defun xterm-reverse-video ()
  "Set xterm to reverse video mode.
For monochrome xterms, this is white foreground on black background.
For xterms which support color, this has the effect of swapping the
foreground and background colors, whatever they may be.

The effect of this command and \\[xterm-normal-video] may be exchanged
if the XTerm*reverseVideo resource property is set to True."
  (interactive)
  (xterm-send-escape-sequence "\e[?5h"))

(defun xterm-normal-video ()
  "Set xterm to normal \(i.e. non-reverse\) video mode.
For monochrome xterms, this is black foreground on white background.
For xterms which support color, this has the effect of restoring the
original foreground and background colors, whatever they may be.

The effect of this command and \\[xterm-reverse-video] may be exchanged
if the XTerm*reverseVideo resource property is set to True."
  (interactive)
  (xterm-send-escape-sequence "\e[?5l"))

(defun xterm-aaa-mode (&optional prefix)
  "Color-emulate an Ann Arbor Ambassador.
With negative prefix argument, reset foreground to white."
  (interactive "p")
  (cond ((> prefix 0)
         (xterm-set-background-color "black")
         (xterm-set-foreground-color "green")
         (xterm-set-cursor-color "green")
         (xterm-set-mouse-foreground-color "black")
         (xterm-set-mouse-background-color "green"))
        (t
         (xterm-set-background-color "black")
         (xterm-set-foreground-color "white")
         (xterm-set-cursor-color "white")
         (xterm-set-mouse-foreground-color "black")
         (xterm-set-mouse-background-color "white"))))


(defun xterm-report-cursor-position ()
  "Return the position of the xterm cursor.
The result is a cons of the form \(COL . ROW\) indicating the offset in
characters from the upper left-hand corner of the window."
  (interactive)
  (and (interactive-p)
       (sit-for 0))
  (let* ((re "\e\\[\\([0-9]+\\);\\([0-9]+\\)R")
         (result (xterm-send-and-read-response "\e[6n" re t))
         (pos (cons (string-to-int (xterm-substring 2 result))
                    (string-to-int (xterm-substring 1 result)))))
    (and (interactive-p)
         (message "COL=%d, ROW=%d" (car pos) (cdr pos)))
    pos))

(defun xterm-report-window-state ()
  "Return 'iconified or 'non-iconified."
  (let ((result (xterm-send-and-read-response "\e[11t" "\e\\[[0-9]+t")))
    (cond ((string= result "\e[1t")
           'non-iconified)
          ((string= result "\e[2t")
           'iconified))))

(defun xterm-report-window-position-pixels ()
  "Return the position of the xterm window on the display.
The result is a cons of the form \(X . Y\) indicating the offset in
pixels from the upper left-hand corner of the display.
Origin is (1 . 1)."
  (interactive)
  (let* ((re "\e\\[3;\\([0-9]+\\);\\([0-9]+\\)t")
         (result (xterm-send-and-read-response "\e[13t" re t))
         (pos (cons (string-to-int (xterm-substring 1 result))
                    (string-to-int (xterm-substring 2 result)))))
    (and (interactive-p)
         (message "X=%d, Y=%d" (car pos) (cdr pos)))
    pos))

(defun xterm-report-window-size-pixels ()
  "Return the size of the xterm window, in pixels.
The result is a cons \(WIDTH . HEIGHT\) indicating the dimensions."
  (interactive)
  (let* ((re "\e\\[4;\\([0-9]+\\);\\([0-9]+\\)t")
         (result (xterm-send-and-read-response "\e[14t" re t))
         (dim (cons (string-to-int (xterm-substring 2 result))
                    (string-to-int (xterm-substring 1 result)))))
    (and (interactive-p)
         (message "%dx%d" (car dim) (cdr dim)))
    dim))

(defun xterm-report-window-size ()
  "Return the size of the xterm window, in character cells.
The result is a cons \(WIDTH . HEIGHT\) indicating the dimensions."
  (interactive)
  (let* ((re "\e\\[8;\\([0-9]+\\);\\([0-9]+\\)t")
         (result (xterm-send-and-read-response "\e[18t" re t))
         (dim (cons (string-to-int (xterm-substring 2 result))
                    (string-to-int (xterm-substring 1 result)))))
    (and (interactive-p)
         (message "%dx%d" (car dim) (cdr dim)))
    dim))

(defun xterm-report-icon-title ()
  "Return the icon label string associated with the xterm window."
  (interactive)
  (let* ((re "\e\\]L\\(.*\\)\e\\\\")
         (result (xterm-send-and-read-response "\e[20t" re t))
         (title (xterm-substring 1 result)))
    (and (interactive-p)
         (message "%s" title))
    title))

(defun xterm-report-window-title ()
  "Return the window title string associated with the xterm window."
  (interactive)
  (let* ((re "\e\\]l\\(.*\\)\e\\\\")
         (result (xterm-send-and-read-response "\e[21t" re t))
         (title (xterm-substring 1 result)))
    (and (interactive-p)
         (message "%s" title))
    title))


(defun xterm-send-and-read-response (string response-re &optional alter-md)
  (xterm-send-escape-sequence string)
  (let ((response "")
        (match-data (match-data)))
    (while (not (string-match response-re response))
      (setq response (concat response (char-to-string (read-char)))))
    (or alter-md
        (store-match-data match-data))
    response))

(defun xterm-send-escape-sequence (string)
  (and xterm-dcs-encapsulation
       (setq string (format xterm-dcs-encapsulation string)))
  (send-string-to-terminal string))

(defun xterm-substring (n &optional string)
  "Return substring matched by last search.
N specifies which match data pair to use
Value is nil if there is no Nth match.
If STRING is not specified, the current buffer is used."
  (if (match-beginning n)
      (if string
	  (substring string (match-beginning n) (match-end n))
	(buffer-substring (match-beginning n) (match-end n)))))

(provide 'xterm-frobs)

;;; xterm-frobs.el ends here