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