code.delx.au - gnu-emacs-elpa/blob - packages/tramp-theme/tramp-theme.el

   1 ;;; tramp-theme.el --- Custom theme for remote buffers
   2
   3 ;; Copyright (C) 2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Michael Albinus <michael.albinus@gmx.de>
   6 ;; Package: tramp-theme
   7 ;; Version: 0.1
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This is not an own custom theme by itself.  Rather, it is a custom
  27 ;; theme to run on top of other custom themes.  It shall be loaded
  28 ;; always as the last custom theme, because it inherits existing
  29 ;; settings.
  30
  31 ;; This custom theme extends `mode-line-buffer-identification' by the
  32 ;; name of the remote host.  It also allows to change faces according
  33 ;; to the value of `default-directory' of a buffer.  See
  34 ;; `tramp-theme-face-remapping-alist' for customization options.
  35
  36 ;;; Code:
  37
  38 (deftheme tramp
  39   "A custom theme to decorate buffers when they are remote.
  40 It can be combined with other custom themes.")
  41
  42 (defcustom tramp-theme-face-remapping-alist
  43   `((nil "^root$"
  44     (mode-line-buffer-id
  45      (:inherit mode-line-buffer-id
  46       :inverse-video
  47       ;; If the face uses already :inverse-video, we deactivate it.
  48       ;; Happens on displays of type 'tty, for example.
  49       ,(null
  50         (face-inverse-video-p
  51          'mode-line-buffer-id nil '(mode-line default)))))))
  52   "Face remapping for decoration of a remote buffer.
  53 This is an alist of items (HOST USER REMAPPING-LIST).  HOST and
  54 USER are regular expressions, or nil.  REMAPPING-LIST must be an
  55 alist of face remappings as used by `face-remapping-alist'.  If
  56 USER matches the remote user part of `default-directory', and
  57 HOST matches the remote host part of `default-directory',
  58 REMAPPING-LIST is applied to the current buffer.
  59
  60 For instance, the following settings change the background color
  61 to \"Red\" for frames connected to the remote host \"foo\", it
  62 changes the background color to \"Green\" for frames connected to
  63 the remote host \"bar\", and it inverses the fringe face for
  64 frames using the remote user \"root\":
  65
  66    '((nil \"^root$\" (fringe (:inherit fringe :inverse-video t)))
  67      (\"^foo$\" nil (default (:background \"Red\")))
  68      (\"^bar$\" nil (default (:background \"Green\"))))
  69
  70 Per default, `mode-line-buffer-identification' is displayed
  71 inverse for buffers which are editable with \"root\" permissions."
  72   :group 'tramp
  73   :type `(repeat (list (choice :tag "Host regexp" regexp (const nil))
  74                        (choice :tag "User regexp" regexp (const nil))
  75                        (list :tag "Face Remapping"
  76                              face (plist :value-type sexp)))))
  77
  78 (defun tramp-theme-original-value (variable)
  79   "Return the original value of VARIABLE before loading `tramp-theme'."
  80   (let ((theme-value (get variable 'theme-value)))
  81     (or (cdr (car (delete (assoc 'tramp theme-value) theme-value)))
  82         (get variable 'tramp-theme-original-value))))
  83
  84 (defun tramp-theme-mode-line-buffer-identification ()
  85   "Return a list suitable for `mode-line-buffer-identification'.
  86 It indicates the remote host being used, if any."
  87   (append
  88    (when (custom-theme-enabled-p 'tramp)
  89      (let ((host (file-remote-p default-directory 'host))
  90            (user (file-remote-p default-directory 'user))
  91             remapping-alist)
  92        ;; Apply `tramp-theme-face-remapping-alist'.
  93        (dolist (elt tramp-theme-face-remapping-alist)
  94          (when (and (string-match (or (nth 0 elt) "") (or host ""))
  95                     (string-match (or (nth 1 elt) "") (or user "")))
  96            (setq remapping-alist (cons (nth 2 elt) remapping-alist))))
  97        (setq-local face-remapping-alist (nreverse remapping-alist))
  98
  99        ;; The extended string.
 100        (when host
 101          ;; Do not use FQDN.
 102          (when (string-match "^[^0-9][^.]*\\(\\..*\\)" host)
 103            (setq host (substring host 0 (match-beginning 1))))
 104          (list
 105           (propertize
 106            (concat (propertize host 'help-echo (purecopy "Host name")) ": ")
 107            'face 'mode-line-buffer-id 'mouse-face 'mode-line-highlight)))))
 108
 109    ;; That's the original definition.
 110    (tramp-theme-original-value 'mode-line-buffer-identification)))
 111
 112 (defun tramp-theme-hook-function ()
 113   "Modify `mode-line-buffer-indication'.
 114 Used in different hooks, in order to accelerate the redisplay."
 115   (setq
 116    mode-line-buffer-identification
 117    (tramp-theme-mode-line-buffer-identification)))
 118
 119 (unless (custom-theme-enabled-p 'tramp)
 120   ;; Save the original value.
 121   (unless (get 'mode-line-buffer-identification 'tramp-theme-original-value)
 122     (put 'mode-line-buffer-identification
 123          'tramp-theme-original-value
 124          mode-line-buffer-identification))
 125
 126   (custom-theme-set-variables
 127    'tramp
 128    ;; Extend `mode-line-buffer-identification' by host name.
 129    '(mode-line-buffer-identification
 130      '(:eval (tramp-theme-mode-line-buffer-identification)))
 131    ;; `dired-mode' overwrites `mode-line-buffer-identification'.  We
 132    ;; want to use our own extension.
 133    '(dired-mode-hook
 134      (cons
 135       'tramp-theme-hook-function
 136       (delete 'tramp-theme-hook-function dired-mode-hook)))
 137    ;; Redisplay doesn't happen immediately.  So we trigger it via
 138    ;; `find-file-hook' and `eshell-directory-change-hook'.
 139    '(find-file-hook
 140      (cons
 141       'tramp-theme-hook-function
 142       (delete 'tramp-theme-hook-function find-file-hook)))
 143    '(eshell-directory-change-hook
 144      (cons
 145       'tramp-theme-hook-function
 146       (delete 'tramp-theme-hook-function eshell-directory-change-hook)))))
 147
 148 (provide-theme 'tramp)
 149
 150 ;;; TODO:
 151
 152 ;; * Use a :type for `tramp-theme-face-remapping-alist' which allows
 153 ;;   to edit the faces.  Maybe use (widget-get custom-face-edit :args)
 154 ;;   for this.
 155
 156 ;; Local Variables:
 157 ;; no-byte-compile: t
 158 ;; End:
 159
 160 ;;; tramp-theme.el ends here