cgit.sxemacs.org Git - packages/blob - xemacs-packages/edit-utils/shell-font.el

   1 ;; Decorate a shell buffer with fonts.
   2 ;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
   3
   4 ;; This file is part of XEmacs.
   5
   6 ;; XEmacs is free software; you can redistribute it and/or modify it
   7 ;; under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2, or (at your option)
   9 ;; any later version.
  10
  11 ;; XEmacs is distributed in the hope that it will be useful, but
  12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;; General Public License for more details.
  15
  16 ;; You should have received a copy of the GNU General Public License
  17 ;; along with XEmacs; see the file COPYING.  If not, write to the
  18 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19 ;; Boston, MA 02111-1307, USA.
  20
  21 ;;; Synched up with: Not in FSF.
  22
  23 ;; Do this: (add-hook 'shell-mode-hook 'install-shell-fonts)
  24 ;; and the prompt in your shell-buffers will appear bold-italic, process
  25 ;; output will appear in normal face, and typein will appear in bold.
  26 ;;
  27 ;; The faces shell-prompt, shell-input and shell-output can be modified
  28 ;; as desired, for example, (copy-face 'italic 'shell-prompt).
  29
  30 ;; Written by Jamie Zawinski, overhauled by Eric Benson.
  31
  32 ;; TODO:
  33 ;; =====
  34 ;; Parse ANSI/VT100 escape sequences to turn on underlining/boldface/etc.
  35 ;; Automatically run nuke-nroff-bs?
  36
  37
  38 (require 'text-props)   ; for put-nonduplicable-text-property
  39
  40 (make-face 'shell-prompt)
  41 (if (not (face-differs-from-default-p 'shell-prompt))
  42     (copy-face 'bold-italic 'shell-prompt))
  43
  44 (make-face 'shell-input)
  45 (if (not (face-differs-from-default-p 'shell-input))
  46     (copy-face 'bold 'shell-input))
  47
  48 (make-face 'shell-output)
  49 (if (not (face-differs-from-default-p 'shell-output))
  50     (progn (make-face-unbold 'shell-output)
  51            (make-face-unitalic 'shell-output)
  52            (set-face-underline-p 'shell-output nil)))
  53
  54 (defvar shell-font-read-only-prompt nil
  55   "*Set all shell prompts to be read-only")
  56
  57 (defvar shell-font-current-face 'shell-input)
  58
  59 (defun shell-font-fontify-region (start end delete-count)
  60   ;; for use as an element of after-change-functions; fontifies the inserted text.
  61   (if (= start end)
  62       nil
  63 ;    ;; This creates lots of extents (one per user-typed character)
  64 ;    ;; which is wasteful of memory.
  65 ;    (let ((e (make-extent start end)))
  66 ;      (set-extent-face e shell-font-current-face)
  67 ;      (set-extent-property e 'shell-font t))
  68
  69     ;; This efficiently merges extents
  70     (put-nonduplicable-text-property start end 'face shell-font-current-face)
  71     (and shell-font-read-only-prompt
  72          (eq shell-font-current-face 'shell-prompt)
  73          (put-nonduplicable-text-property start end 'read-only t))
  74     ))
  75
  76 (defun shell-font-hack-prompt (limit)
  77   "Search backward from point-max for text matching the comint-prompt-regexp,
  78 and put it in the `shell-prompt' face.  LIMIT is the left bound of the search."
  79   (save-excursion
  80     (goto-char (point-max))
  81     (save-match-data
  82      (cond ((re-search-backward comint-prompt-regexp limit t)
  83             (goto-char (match-end 0))
  84             (cond ((= (point) (point-max))
  85                    (skip-chars-backward " \t")
  86                    (let ((shell-font-current-face 'shell-prompt))
  87                      (shell-font-fontify-region
  88                       (match-beginning 0) (point) 0)))))))))
  89
  90 ;; David Hughes 22nd April 1998
  91 (defun shell-font-hack-input (string)
  92   (save-excursion
  93     (save-match-data
  94       (goto-char (- (point-max) (length (replace-in-string string "\^M" ""))))
  95       (skip-chars-forward " \t")
  96       (let ((beg (point))
  97             (end (save-excursion (re-search-forward "\n" nil t)))
  98             (shell-font-current-face 'shell-input))
  99         (beginning-of-line)
 100         (and end
 101              (looking-at comint-prompt-regexp)
 102              (re-search-forward comint-prompt-regexp)
 103              (= beg (point))
 104              (shell-font-fontify-region beg end 0))))))
 105
 106 (defvar shell-font-process-filter nil
 107   "In an interaction buffer with shell-font, this is the original proc filter.
 108 shell-font encapsulates this.")
 109
 110 (defun shell-font-process-filter (proc string)
 111   "Invoke the original process filter, then set fonts on the output.
 112 The original filter is in the buffer-local variable shell-font-process-filter."
 113   (let ((cb (current-buffer))
 114         (pb (process-buffer proc)))
 115     (if (null pb)
 116         ;; If the proc has no buffer, leave it alone.
 117         (funcall shell-font-process-filter proc string)
 118       ;; Don't do save excursion because some proc filters want to change
 119       ;; the buffer's point.
 120       (set-buffer pb)
 121       (let ((p (marker-position (process-mark proc))))
 122         (prog1
 123             ;; this let must not be around the `set-buffer' call.
 124             (let ((shell-font-current-face 'shell-output))
 125               (funcall shell-font-process-filter proc string))
 126           (shell-font-hack-prompt p)
 127           ;; David Hughes 22nd April 1998
 128           (if comint-process-echoes (shell-font-hack-input string))
 129           (set-buffer cb))))))
 130
 131 ;;;###autoload
 132 (defun install-shell-fonts ()
 133   "Decorate the current interaction buffer with fonts.
 134 This uses the faces called `shell-prompt', `shell-input' and `shell-output';
 135 you can alter the graphical attributes of those with the normal
 136 face-manipulation functions."
 137   (let* ((proc (or (get-buffer-process (current-buffer))
 138                    (error "no process in %S" (current-buffer))))
 139          (old (or (process-filter proc)
 140                   (error "no process filter on %S" proc))))
 141     (make-local-variable 'after-change-functions)
 142     (add-hook 'after-change-functions 'shell-font-fontify-region)
 143     (make-local-variable 'shell-font-current-face)
 144     (setq shell-font-current-face 'shell-input)
 145     (make-local-variable 'shell-font-process-filter)
 146     (or (eq old 'shell-font-process-filter) ; already set
 147         (setq shell-font-process-filter old))
 148     (set-process-filter proc 'shell-font-process-filter))
 149   nil)
 150
 151 (add-hook 'shell-mode-hook      'install-shell-fonts)
 152 (add-hook 'telnet-mode-hook     'install-shell-fonts)
 153 (add-hook 'gdb-mode-hook        'install-shell-fonts)
 154
 155 ;; for compatibility with the 19.8 version
 156 ;(fset 'install-shell-font-prompt 'install-shell-fonts)
 157 (make-obsolete 'install-shell-font-prompt 'install-shell-fonts)
 158
 159 (provide 'shell-font)
 160
 161 ;;; shell-font.el ends here