[elpa] externals/tramp-theme 0bd97ef 1/8: Add tramp-theme

[Stefan Monnier]

branch: externals/tramp-theme
commit 0bd97eff08be6afb79a5026bce4a88527017eb6e
Author: Michael Albinus <michael.albinus@gmx.de>
Commit: Michael Albinus <michael.albinus@gmx.de>

    Add tramp-theme
    
    * packages/tramp-theme/README:
    * packages/tramp-theme/tramp-theme.el: New files.
---
 README         |  11 ++++
 tramp-theme.el | 160 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 171 insertions(+)

diff --git a/README b/README
new file mode 100644
index 0000000..093c1f0
--- /dev/null
+++ b/README
@@ -0,0 +1,11 @@
+This is a custom theme for remote buffers.
+
+It is not an own custom theme by itself.  Rather, it is a custom
+theme to run on top of other custom themes.  It shall be loaded
+always as the last custom theme, because it inherits existing
+settings.
+
+This custom theme extends `mode-line-buffer-identification' by the
+name of the remote host.  It also allows to change faces according
+to the value of `default-directory' of a buffer.  See
+`tramp-theme-face-remapping-alist' for customization options.
diff --git a/tramp-theme.el b/tramp-theme.el
new file mode 100644
index 0000000..3e80257
--- /dev/null
+++ b/tramp-theme.el
@@ -0,0 +1,160 @@
+;;; tramp-theme.el --- Custom theme for remote buffers
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Michael Albinus <michael.albinus@gmx.de>
+;; Package: tramp-theme
+;; Version: 0.1
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This is not an own custom theme by itself.  Rather, it is a custom
+;; theme to run on top of other custom themes.  It shall be loaded
+;; always as the last custom theme, because it inherits existing
+;; settings.
+
+;; This custom theme extends `mode-line-buffer-identification' by the
+;; name of the remote host.  It also allows to change faces according
+;; to the value of `default-directory' of a buffer.  See
+;; `tramp-theme-face-remapping-alist' for customization options.
+
+;;; Code:
+
+(deftheme tramp
+  "A custom theme to decorate buffers when they are remote.
+It can be combined with other custom themes.")
+
+(defcustom tramp-theme-face-remapping-alist
+  `((nil "^root$"
+    (mode-line-buffer-id
+     (:inherit mode-line-buffer-id
+      :inverse-video
+      ;; If the face uses already :inverse-video, we deactivate it.
+      ;; Happens on displays of type 'tty, for example.
+      ,(null
+       (face-inverse-video-p
+        'mode-line-buffer-id nil '(mode-line default)))))))
+  "Face remapping for decoration of a remote buffer.
+This is an alist of items (HOST USER REMAPPING-LIST).  HOST and
+USER are regular expressions, or nil.  REMAPPING-LIST must be an
+alist of face remappings as used by `face-remapping-alist'.  If
+USER matches the remote user part of `default-directory', and
+HOST matches the remote host part of `default-directory',
+REMAPPING-LIST is applied to the current buffer.
+
+For instance, the following settings change the background color
+to \"Red\" for frames connected to the remote host \"foo\", it
+changes the background color to \"Green\" for frames connected to
+the remote host \"bar\", and it inverses the fringe face for
+frames using the remote user \"root\":
+
+   '((nil \"^root$\" (fringe (:inherit fringe :inverse-video t)))
+     (\"^foo$\" nil (default (:background \"Red\")))
+     (\"^bar$\" nil (default (:background \"Green\"))))
+
+Per default, `mode-line-buffer-identification' is displayed
+inverse for buffers which are editable with \"root\" permissions."
+  :group 'tramp
+  :type `(repeat (list (choice :tag "Host regexp" regexp (const nil))
+                      (choice :tag "User regexp" regexp (const nil))
+                      (list :tag "Face Remapping"
+                            face (plist :value-type sexp)))))
+
+(defun tramp-theme-original-value (variable)
+  "Return the original value of VARIABLE before loading `tramp-theme'."
+  (let ((theme-value (get variable 'theme-value)))
+    (or (cdr (car (delete (assoc 'tramp theme-value) theme-value)))
+       (get variable 'tramp-theme-original-value))))
+
+(defun tramp-theme-mode-line-buffer-identification ()
+  "Return a list suitable for `mode-line-buffer-identification'.
+It indicates the remote host being used, if any."
+  (append
+   (when (custom-theme-enabled-p 'tramp)
+     (let ((host (file-remote-p default-directory 'host))
+          (user (file-remote-p default-directory 'user))
+           remapping-alist)
+       ;; Apply `tramp-theme-face-remapping-alist'.
+       (dolist (elt tramp-theme-face-remapping-alist)
+        (when (and (string-match (or (nth 0 elt) "") (or host ""))
+                   (string-match (or (nth 1 elt) "") (or user "")))
+          (setq remapping-alist (cons (nth 2 elt) remapping-alist))))
+       (setq-local face-remapping-alist (nreverse remapping-alist))
+
+       ;; The extended string.
+       (when host
+        ;; Do not use FQDN.
+        (when (string-match "^[^0-9][^.]*\\(\\..*\\)" host)
+          (setq host (substring host 0 (match-beginning 1))))
+        (list
+         (propertize
+          (concat (propertize host 'help-echo (purecopy "Host name")) ": ")
+          'face 'mode-line-buffer-id 'mouse-face 'mode-line-highlight)))))
+
+   ;; That's the original definition.
+   (tramp-theme-original-value 'mode-line-buffer-identification)))
+
+(defun tramp-theme-hook-function ()
+  "Modify `mode-line-buffer-indication'.
+Used in different hooks, in order to accelerate the redisplay."
+  (setq
+   mode-line-buffer-identification
+   (tramp-theme-mode-line-buffer-identification)))
+
+(unless (custom-theme-enabled-p 'tramp)
+  ;; Save the original value.
+  (unless (get 'mode-line-buffer-identification 'tramp-theme-original-value)
+    (put 'mode-line-buffer-identification
+        'tramp-theme-original-value
+        mode-line-buffer-identification))
+
+  (custom-theme-set-variables
+   'tramp
+   ;; Extend `mode-line-buffer-identification' by host name.
+   '(mode-line-buffer-identification
+     '(:eval (tramp-theme-mode-line-buffer-identification)))
+   ;; `dired-mode' overwrites `mode-line-buffer-identification'.  We
+   ;; want to use our own extension.
+   '(dired-mode-hook
+     (cons
+      'tramp-theme-hook-function
+      (delete 'tramp-theme-hook-function dired-mode-hook)))
+   ;; Redisplay doesn't happen immediately.  So we trigger it via
+   ;; `find-file-hook' and `eshell-directory-change-hook'.
+   '(find-file-hook
+     (cons
+      'tramp-theme-hook-function
+      (delete 'tramp-theme-hook-function find-file-hook)))
+   '(eshell-directory-change-hook
+     (cons
+      'tramp-theme-hook-function
+      (delete 'tramp-theme-hook-function eshell-directory-change-hook)))))
+
+(provide-theme 'tramp)
+
+;;; TODO:
+
+;; * Use a :type for `tramp-theme-face-remapping-alist' which allows
+;;   to edit the faces.  Maybe use (widget-get custom-face-edit :args)
+;;   for this.
+
+;; Local Variables:
+;; no-byte-compile: t
+;; End:
+
+;;; tramp-theme.el ends here