lisp/files-x.el

   1 ;;; files-x.el --- extended file handling commands
   2
   3 ;; Copyright (C) 2009-2018 Free Software Foundation, Inc.
   4
   5 ;; Author: Juri Linkov <juri@jurta.org>
   6 ;; Maintainer: emacs-devel@gnu.org
   7 ;; Keywords: files
   8 ;; Package: emacs
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This file defines additional infrequently used file- and
  28 ;; directory-handling commands that should not be in files.el
  29 ;; to not make the dumped image bigger.
  30
  31 ;;; Code:
  32
  33 \f
  34 ;;; Commands to add/delete file-local/directory-local variables.
  35
  36 (defun read-file-local-variable (prompt)
  37   "Read file-local variable using PROMPT and completion.
  38 Intended to be used in the `interactive' spec of
  39 `add-file-local-variable', `delete-file-local-variable',
  40 `add-dir-local-variable', `delete-dir-local-variable'."
  41   (let* ((default (variable-at-point))
  42          (default (and (symbolp default) (boundp default)
  43                        (symbol-name default)))
  44          (variable
  45           (completing-read
  46            (if default
  47                (format "%s (default %s): " prompt default)
  48              (format "%s: " prompt))
  49            obarray
  50            (lambda (sym)
  51              (or (custom-variable-p sym)
  52                  (get sym 'safe-local-variable)
  53                  (memq sym '(mode eval coding unibyte))))
  54            nil nil nil default nil)))
  55     (and (stringp variable) (intern variable))))
  56
  57 (defun read-file-local-variable-value (variable)
  58   "Read value of file-local VARIABLE using completion.
  59 Intended to be used in the `interactive' spec of
  60 `add-file-local-variable' and `add-dir-local-variable'."
  61   (cond
  62    ((eq variable 'mode)
  63     (let* ((default (and (symbolp major-mode) (symbol-name major-mode)))
  64            (value
  65             (completing-read
  66              (if default
  67                  (format "Add %s with value (default %s): " variable default)
  68                (format "Add %s with value: " variable))
  69              obarray
  70              (lambda (sym)
  71                (string-match-p "-mode\\'" (symbol-name sym)))
  72              nil nil nil default nil)))
  73       (and (stringp value)
  74            (intern (replace-regexp-in-string "-mode\\'" "" value)))))
  75    ((eq variable 'eval)
  76     (read--expression (format "Add %s with expression: " variable)))
  77    ((eq variable 'coding)
  78     (let ((default (and (symbolp buffer-file-coding-system)
  79                         (symbol-name buffer-file-coding-system))))
  80       (read-coding-system
  81        (if default
  82            (format "Add %s with value (default %s): " variable default)
  83          (format "Add %s with value: " variable))
  84        default)))
  85    (t
  86     (let ((default (format "%S"
  87                            (cond ((eq variable 'unibyte) t)
  88                                  ((boundp variable)
  89                                   (symbol-value variable)))))
  90           (minibuffer-completing-symbol t))
  91       (read-from-minibuffer (format "Add %s with value: " variable)
  92                             nil read-expression-map t
  93                             'set-variable-value-history
  94                             default)))))
  95
  96 (defun read-file-local-variable-mode ()
  97   "Read per-directory file-local variable's mode using completion.
  98 Intended to be used in the `interactive' spec of
  99 `add-dir-local-variable', `delete-dir-local-variable'."
 100   (let* ((default (and (symbolp major-mode) (symbol-name major-mode)))
 101          (mode
 102           (completing-read
 103            (if default
 104                (format "Mode or subdirectory (default %s): " default)
 105              (format "Mode or subdirectory: "))
 106            obarray
 107            (lambda (sym)
 108              (and (string-match-p "-mode\\'" (symbol-name sym))
 109                   (not (or (memq sym minor-mode-list)
 110                            (string-match-p "-minor-mode\\'"
 111                                            (symbol-name sym))))))
 112            nil nil nil default nil)))
 113     (cond
 114      ((equal mode "nil") nil)
 115      ((and (stringp mode) (fboundp (intern mode))) (intern mode))
 116      (t mode))))
 117
 118 (defun modify-file-local-variable-message (variable value op)
 119   (let* ((not-value (make-symbol ""))
 120          (old-value (cond ((eq variable 'mode)
 121                            major-mode)
 122                           ((eq variable 'coding)
 123                            buffer-file-coding-system)
 124                           (t (if (and (symbolp variable)
 125                                       (boundp variable))
 126                                  (symbol-value variable)
 127                                not-value))))
 128          (new-value (if (eq op 'delete)
 129                         (cond ((eq variable 'mode)
 130                                (default-value 'major-mode))
 131                               ((eq variable 'coding)
 132                                (default-value 'buffer-file-coding-system))
 133                               (t (if (and (symbolp variable)
 134                                           (default-boundp variable))
 135                                      (default-value variable)
 136                                    not-value)))
 137                       (cond ((eq variable 'mode)
 138                              (let ((string (format "%S" value)))
 139                                (if (string-match-p "-mode\\'" string)
 140                                    value
 141                                  (intern (concat string "-mode")))))
 142                             (t value)))))
 143     (when (or (eq old-value not-value)
 144               (eq new-value not-value)
 145               (not (equal old-value new-value)))
 146       (message "%s" (substitute-command-keys
 147                      "For this change to take effect revisit file using \\[revert-buffer]")))))
 148
 149 (defun modify-file-local-variable (variable value op &optional interactive)
 150   "Modify file-local VARIABLE in Local Variables depending on operation OP.
 151
 152 If OP is `add-or-replace' then delete all existing settings of
 153 VARIABLE (except `mode' and `eval') and add a new file-local VARIABLE
 154 with VALUE to the Local Variables list.
 155
 156 If there is no Local Variables list in the current file buffer and OP
 157 is not `delete' then this function adds the first line containing the
 158 string `Local Variables:' and the last line containing the string `End:'.
 159
 160 If OP is `delete' then delete all existing settings of VARIABLE
 161 from the Local Variables list ignoring the input argument VALUE."
 162   (catch 'exit
 163     (let ((beg (point)) end replaced-pos)
 164       (unless enable-local-variables
 165         (throw 'exit (message "File-local variables are disabled")))
 166
 167       ;; Look for "Local variables:" line in last page.
 168       (widen)
 169       (goto-char (point-max))
 170       (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move)
 171
 172       ;; Add "Local variables:" list if not found.
 173       (unless (let ((case-fold-search t))
 174                 (search-forward "Local Variables:" nil t))
 175
 176         ;; Don't add "Local variables:" list for the deletion operation.
 177         (when (eq op 'delete)
 178           (throw 'exit (progn (goto-char beg)
 179                               (message "Local Variables not found"))))
 180
 181         (goto-char (point-max))
 182         (let ((comment-style 'plain)
 183               (comment-start (or comment-start ";; ")))
 184           (comment-region
 185            (prog1 (setq beg (point))
 186              (insert "\nLocal Variables:\nEnd:\n"))
 187            (point)))
 188
 189         (unless (let ((case-fold-search t))
 190                   (goto-char beg)
 191                   (search-forward "Local Variables:" nil t))
 192           (throw 'exit (message "Can't add file-local variables"))))
 193
 194       ;; prefix is what comes before "local variables:" in its line.
 195       ;; suffix is what comes after "local variables:" in its line.
 196       (let* ((prefix (buffer-substring (line-beginning-position)
 197                                        (match-beginning 0)))
 198              (suffix (buffer-substring (point) (line-end-position)))
 199              (prefix-re (concat "^" (regexp-quote prefix)))
 200              (suffix-re (concat (regexp-quote suffix) "$")))
 201
 202         ;; Find or add missing "End:".
 203         (forward-line 1)
 204         (setq beg (point))
 205         (save-excursion
 206           (unless (let ((case-fold-search t))
 207                     (re-search-forward
 208                      (concat prefix-re "[ \t]*End:[ \t]*" suffix-re)
 209                      nil t))
 210             (save-excursion
 211               (insert (format "%sEnd:%s\n" prefix suffix))))
 212           (beginning-of-line)
 213           (setq end (point-marker)))
 214
 215         ;; Find and delete all existing variable/value pairs.
 216         (when (member op '(add-or-replace delete))
 217           (if (and (eq op 'add-or-replace) (memq variable '(mode eval)))
 218               (goto-char end)
 219             (goto-char beg)
 220             (while (re-search-forward
 221                     (format "%s%S:.*%s" prefix-re variable suffix-re) end t)
 222               (delete-region (match-beginning 0) (1+ (match-end 0)))
 223               (setq replaced-pos (point)))))
 224
 225         ;; Add a new variable/value pair.  Add `mode' to the start, add new
 226         ;; variable to the end, and add a replaced variable to its last location.
 227         (when (eq op 'add-or-replace)
 228           (cond
 229            ((eq variable 'mode) (goto-char beg))
 230            ((null replaced-pos) (goto-char end))
 231            (replaced-pos (goto-char replaced-pos)))
 232           (insert (format "%s%S: %S%s\n" prefix variable value suffix))))
 233
 234       (when interactive
 235         (modify-file-local-variable-message variable value op)))))
 236
 237 ;;;###autoload
 238 (defun add-file-local-variable (variable value &optional interactive)
 239   "Add file-local VARIABLE with its VALUE to the Local Variables list.
 240
 241 This command deletes all existing settings of VARIABLE (except `mode'
 242 and `eval') and adds a new file-local VARIABLE with VALUE to the
 243 Local Variables list.
 244
 245 If there is no Local Variables list in the current file buffer
 246 then this function adds the first line containing the string
 247 `Local Variables:' and the last line containing the string `End:'."
 248   (interactive
 249    (let ((variable (read-file-local-variable "Add file-local variable")))
 250      ;; Error before reading value.
 251      (if (equal variable 'lexical-binding)
 252          (user-error "The `%s' variable must be set at the start of the file"
 253                      variable))
 254      (list variable (read-file-local-variable-value variable) t)))
 255   (if (equal variable 'lexical-binding)
 256       (user-error "The `%s' variable must be set at the start of the file"
 257                   variable))
 258   (modify-file-local-variable variable value 'add-or-replace interactive))
 259
 260 ;;;###autoload
 261 (defun delete-file-local-variable (variable &optional interactive)
 262   "Delete all settings of file-local VARIABLE from the Local Variables list."
 263   (interactive
 264    (list (read-file-local-variable "Delete file-local variable") t))
 265   (modify-file-local-variable variable nil 'delete interactive))
 266
 267 (defun modify-file-local-variable-prop-line (variable value op &optional interactive)
 268   "Modify file-local VARIABLE in the -*- line depending on operation OP.
 269
 270 If OP is `add-or-replace' then delete all existing settings of
 271 VARIABLE (except `mode' and `eval') and add a new file-local VARIABLE
 272 with VALUE to the -*- line.
 273
 274 If there is no -*- line at the beginning of the current file buffer
 275 and OP is not `delete' then this function adds the -*- line.
 276
 277 If OP is `delete' then delete all existing settings of VARIABLE
 278 from the -*- line ignoring the input argument VALUE."
 279   (catch 'exit
 280     (let ((beg (point)) end replaced-pos)
 281       (unless enable-local-variables
 282         (throw 'exit (message "File-local variables are disabled")))
 283
 284       ;; Find the -*- line at the beginning of the current buffer.
 285       (widen)
 286       (goto-char (point-min))
 287       (setq end (set-auto-mode-1))
 288
 289       (if end
 290           (setq beg (point-marker) end (copy-marker end))
 291
 292         ;; Add the -*- line if not found.
 293         ;; Don't add the -*- line for the deletion operation.
 294         (when (eq op 'delete)
 295           (throw 'exit (progn (goto-char beg)
 296                               (message "The -*- line not found"))))
 297
 298         (goto-char (point-min))
 299
 300         ;; Skip interpreter magic line "#!" or XML declaration.
 301         (when (or (looking-at file-auto-mode-skip)
 302                   (looking-at "<\\?xml[^>\n]*>$"))
 303           (forward-line 1))
 304
 305         (let ((comment-style 'plain)
 306               (comment-start (or comment-start ";;; "))
 307               (line-beg (line-beginning-position))
 308               (ce nil))
 309           (comment-normalize-vars)
 310           ;; If the first line contains a comment.
 311           (if (save-excursion
 312                 (and (looking-at comment-start-skip)
 313                      (goto-char (match-end 0))
 314                      (re-search-forward comment-end-skip)
 315                      (goto-char (match-beginning 0))
 316                      ;; Still on the same line?
 317                      (equal line-beg (line-beginning-position))
 318                      (setq ce (point))))
 319               ;; Add local variables to the end of the existing comment.
 320               (progn
 321                 (goto-char ce)
 322                 (insert "  -*-")
 323                 (setq beg (point-marker))
 324                 (setq end (point-marker))
 325                 (insert "-*-"))
 326             ;; Otherwise, add a new comment before the first line.
 327             (comment-region
 328              (prog1 (point)
 329                (insert "-*-")
 330                (setq beg (point-marker))
 331                (setq end (point-marker))
 332                (insert "-*-\n"))
 333              (point)))))
 334
 335       (cond
 336        ((looking-at "[ \t]*\\([^ \t\n\r:;]+\\)\\([ \t]*-\\*-\\)")
 337         ;; Simple form: "-*- MODENAME -*-".
 338         (if (eq variable 'mode)
 339             ;; Replace or delete MODENAME
 340             (progn
 341               (when (member op '(add-or-replace delete))
 342                 (delete-region (match-beginning 1) (match-end 1)))
 343               (when (eq op 'add-or-replace)
 344                 (goto-char (match-beginning 1))
 345                 (insert (format "%S" value))))
 346           ;; Else, turn `MODENAME' into `mode:MODENAME'
 347           ;; and add `VARIABLE: VALUE;'
 348           (goto-char (match-beginning 2))
 349           (insert (format "; %S: %S; " variable value))
 350           (goto-char (match-beginning 1))
 351           (insert " mode: ")))
 352
 353        (t
 354         ;; Hairy form: '-*-' [ <variable> ':' <value> ';' ]* '-*-'
 355         ;; Find and delete all existing variable/value pairs.
 356         (when (member op '(add-or-replace delete))
 357           (if (and (eq op 'add-or-replace) (memq variable '(mode eval)))
 358               (goto-char end)
 359             (goto-char beg)
 360             (while (< (point) end)
 361               (or (looking-at "[ \t]*\\([^ \t\n:]+\\)[ \t]*:[ \t]*")
 362                   (throw 'exit (message "Malformed -*- line")))
 363               (goto-char (match-end 0))
 364               (let ((key (intern (match-string 1))))
 365                 (save-restriction
 366                   (narrow-to-region (point) end)
 367                   (let ((read-circle nil))
 368                     (read (current-buffer))))
 369                 (skip-chars-forward " \t;")
 370                 (when (eq key variable)
 371                   (delete-region (match-beginning 0) (point))
 372                   (setq replaced-pos (point)))))))
 373         ;; Add a new variable/value pair.  Add `mode' to the start, add new
 374         ;; variable to the end, and add a replaced variable to its last location.
 375         (when (eq op 'add-or-replace)
 376           (cond
 377            ((eq variable 'mode) (goto-char beg))
 378            ((null replaced-pos) (goto-char end))
 379            (replaced-pos (goto-char replaced-pos)))
 380           (if (and (save-excursion
 381                      (skip-chars-backward " \t")
 382                      (not (eq (char-before) ?\;)))
 383                    (not (equal (point) (marker-position beg)))
 384                    ;; When existing `-*- -*-' is empty, beg > end.
 385                    (not (> (marker-position beg) (marker-position end))))
 386               (insert ";"))
 387           (unless (eq (char-before) ?\s) (insert " "))
 388           (insert (format "%S: %S;" variable value))
 389           (unless (eq (char-after) ?\s) (insert " ")))))
 390
 391       (when interactive
 392         (modify-file-local-variable-message variable value op)))))
 393
 394 ;;;###autoload
 395 (defun add-file-local-variable-prop-line (variable value &optional interactive)
 396   "Add file-local VARIABLE with its VALUE to the -*- line.
 397
 398 This command deletes all existing settings of VARIABLE (except `mode'
 399 and `eval') and adds a new file-local VARIABLE with VALUE to
 400 the -*- line.
 401
 402 If there is no -*- line at the beginning of the current file buffer
 403 then this function adds it."
 404   (interactive
 405    (let ((variable (read-file-local-variable "Add -*- file-local variable")))
 406      (list variable (read-file-local-variable-value variable) t)))
 407   (modify-file-local-variable-prop-line variable value 'add-or-replace interactive))
 408
 409 ;;;###autoload
 410 (defun delete-file-local-variable-prop-line (variable &optional interactive)
 411   "Delete all settings of file-local VARIABLE from the -*- line."
 412   (interactive
 413    (list (read-file-local-variable "Delete -*- file-local variable") t))
 414   (modify-file-local-variable-prop-line variable nil 'delete interactive))
 415
 416 (defvar auto-insert) ; from autoinsert.el
 417
 418 (defun modify-dir-local-variable (mode variable value op)
 419   "Modify directory-local VARIABLE in .dir-locals.el depending on operation OP.
 420
 421 If OP is `add-or-replace' then delete all existing settings of
 422 VARIABLE (except `mode' and `eval') and add a new directory-local VARIABLE
 423 with VALUE to the MODE alist where MODE can be a mode name symbol or
 424 a subdirectory name.
 425
 426 If .dir-locals.el was not found and OP is not `delete' then create
 427 this file in the current directory.
 428
 429 If OP is `delete' then delete all existing settings of VARIABLE
 430 from the MODE alist ignoring the input argument VALUE."
 431   (catch 'exit
 432     (unless enable-local-variables
 433       (throw 'exit (message "Directory-local variables are disabled")))
 434     (let* ((dir-or-cache (and (buffer-file-name)
 435                               (not (file-remote-p (buffer-file-name)))
 436                               (dir-locals-find-file (buffer-file-name))))
 437            (variables-file
 438             ;; If there are several .dir-locals, the user probably
 439             ;; wants to edit the last one (the highest priority).
 440             (cond ((stringp dir-or-cache)
 441                    (car (last (dir-locals--all-files dir-or-cache))))
 442                   ((consp dir-or-cache) ; result from cache
 443                    ;; If cache element has an mtime, assume it came
 444                    ;; from a file.  Otherwise, assume it was set
 445                    ;; directly.
 446                    (if (nth 2 dir-or-cache)
 447                        (car (last (dir-locals--all-files (car dir-or-cache))))
 448                      (cadr dir-or-cache)))
 449                   ;; Try to make a proper file-name.
 450                   (t (expand-file-name dir-locals-file))))
 451            variables)
 452       ;; I can't be bothered to handle this case right now.
 453       ;; Dir locals were set directly from a class.  You need to
 454       ;; directly modify the class in dir-locals-class-alist.
 455       (and variables-file (not (stringp variables-file))
 456            (throw 'exit (message "Directory locals were not set from a file")))
 457       ;; Don't create ".dir-locals.el" for the deletion operation.
 458       (and (eq op 'delete)
 459            (or (not variables-file)
 460                (not (file-exists-p variables-file)))
 461            (throw 'exit (message "No .dir-locals.el file was found")))
 462       (let ((auto-insert nil))
 463         (find-file variables-file))
 464       (widen)
 465       (goto-char (point-min))
 466
 467       ;; Read alist of directory-local variables.
 468       (ignore-errors
 469         (delete-region
 470          (prog1 (point)
 471            (setq variables (let ((read-circle nil))
 472                              (read (current-buffer)))))
 473          (point)))
 474
 475       ;; Add or replace variable in alist of directory-local variables.
 476       (let ((mode-assoc (assoc mode variables)))
 477         (if mode-assoc
 478             (setq variables
 479                   (cons (cons mode
 480                               (if (eq op 'delete)
 481                                   (assq-delete-all variable (cdr mode-assoc))
 482                                 (cons
 483                                  (cons variable value)
 484                                  (if (memq variable '(mode eval))
 485                                      (cdr mode-assoc)
 486                                    (assq-delete-all variable (cdr mode-assoc))))))
 487                         (assq-delete-all mode variables)))
 488           (setq variables
 489                 (cons `(,mode . ((,variable . ,value)))
 490                       variables))))
 491
 492       ;; Insert modified alist of directory-local variables.
 493       (insert ";;; Directory Local Variables\n")
 494       (insert ";;; For more information see (info \"(emacs) Directory Variables\")\n\n")
 495       (princ (add-dir-local-variables-to-string
 496               (sort variables
 497                     (lambda (a b)
 498                       (cond
 499                        ((null (car a)) t)
 500                        ((null (car b)) nil)
 501                        ((and (symbolp (car a)) (stringp (car b))) t)
 502                        ((and (symbolp (car b)) (stringp (car a))) nil)
 503                        (t (string< (car a) (car b)))))))
 504              (current-buffer))
 505       (goto-char (point-min))
 506       (indent-sexp))))
 507
 508 (defun add-dir-local-variables-to-string (variables)
 509   "Output alists of VARIABLES to string in dotted pair notation syntax."
 510   (format "(%s)" (mapconcat
 511                   (lambda (mode-variable)
 512                     (format "(%S . %s)"
 513                             (car mode-variable)
 514                             (format "(%s)" (mapconcat
 515                                             (lambda (variable-value)
 516                                               (format "(%s . %S)"
 517                                                       (car variable-value)
 518                                                       (cdr variable-value)))
 519                                             (cdr mode-variable) "\n"))))
 520                   variables "\n")))
 521
 522 ;;;###autoload
 523 (defun add-dir-local-variable (mode variable value)
 524   "Add directory-local VARIABLE with its VALUE and MODE to .dir-locals.el."
 525   (interactive
 526    (let (variable)
 527      (list
 528       (read-file-local-variable-mode)
 529       (setq variable (read-file-local-variable "Add directory-local variable"))
 530       (read-file-local-variable-value variable))))
 531   (modify-dir-local-variable mode variable value 'add-or-replace))
 532
 533 ;;;###autoload
 534 (defun delete-dir-local-variable (mode variable)
 535   "Delete all MODE settings of file-local VARIABLE from .dir-locals.el."
 536   (interactive
 537    (list
 538     (read-file-local-variable-mode)
 539     (read-file-local-variable "Delete directory-local variable")))
 540   (modify-dir-local-variable mode variable nil 'delete))
 541
 542 ;;;###autoload
 543 (defun copy-file-locals-to-dir-locals ()
 544   "Copy file-local variables to .dir-locals.el."
 545   (interactive)
 546   (dolist (elt file-local-variables-alist)
 547     (unless (assq (car elt) dir-local-variables-alist)
 548       (add-dir-local-variable major-mode (car elt) (cdr elt)))))
 549
 550 ;;;###autoload
 551 (defun copy-dir-locals-to-file-locals ()
 552   "Copy directory-local variables to the Local Variables list."
 553   (interactive)
 554   (dolist (elt dir-local-variables-alist)
 555     (add-file-local-variable (car elt) (cdr elt))))
 556
 557 ;;;###autoload
 558 (defun copy-dir-locals-to-file-locals-prop-line ()
 559   "Copy directory-local variables to the -*- line."
 560   (interactive)
 561   (dolist (elt dir-local-variables-alist)
 562     (add-file-local-variable-prop-line (car elt) (cdr elt))))
 563
 564 \f
 565 ;;; connection-local variables.
 566
 567 ;;;###autoload
 568 (defvar enable-connection-local-variables t
 569   "Non-nil means enable use of connection-local variables.")
 570
 571 (defvar connection-local-variables-alist nil
 572   "Alist of connection-local variable settings in the current buffer.
 573 Each element in this list has the form (VAR . VALUE), where VAR
 574 is a connection-local variable (a symbol) and VALUE is its value.
 575 The actual value in the buffer may differ from VALUE, if it is
 576 changed by the user.")
 577 (make-variable-buffer-local 'connection-local-variables-alist)
 578 (setq ignored-local-variables
 579       (cons 'connection-local-variables-alist ignored-local-variables))
 580
 581 (defvar connection-local-profile-alist '()
 582   "Alist mapping connection profiles to variable lists.
 583 Each element in this list has the form (PROFILE VARIABLES).
 584 PROFILE is the name of a connection profile (a symbol).
 585 VARIABLES is a list that declares connection-local variables for
 586 PROFILE.  An element in VARIABLES is an alist whose elements are
 587 of the form (VAR . VALUE).")
 588
 589 (defvar connection-local-criteria-alist '()
 590   "Alist mapping connection criteria to connection profiles.
 591 Each element in this list has the form (CRITERIA PROFILES).
 592 CRITERIA is a plist identifying a connection and the application
 593 using this connection.  Property names might be `:application',
 594 `:protocol', `:user' and `:machine'.  The property value of
 595 `:application' is a symbol, all other property values are
 596 strings.  All properties are optional; if CRITERIA is nil, it
 597 always applies.
 598 PROFILES is a list of connection profiles (symbols).")
 599
 600 (defsubst connection-local-normalize-criteria (criteria)
 601   "Normalize plist CRITERIA according to properties.
 602 Return a reordered plist."
 603   (apply
 604    'append
 605    (mapcar
 606     (lambda (property)
 607       (when (and (plist-member criteria property) (plist-get criteria property))
 608         (list property (plist-get criteria property))))
 609     '(:application :protocol :user :machine))))
 610
 611 (defsubst connection-local-get-profiles (criteria)
 612   "Return the connection profiles list for CRITERIA.
 613 CRITERIA is a plist identifying a connection and the application
 614 using this connection, see `connection-local-criteria-alist'."
 615   (let (profiles)
 616     (dolist (crit-alist connection-local-criteria-alist)
 617       (let ((crit criteria)
 618             (match t))
 619         (while (and crit match)
 620           (when (plist-member (car crit-alist) (car crit))
 621             (setq match (equal (plist-get (car crit-alist) (car crit))
 622                                (plist-get criteria (car crit)))))
 623           (setq crit (cddr crit)))
 624         (when match
 625           (setq profiles (append profiles (cdr crit-alist))))))
 626     (delete-dups profiles)))
 627
 628 ;;;###autoload
 629 (defun connection-local-set-profiles (criteria &rest profiles)
 630   "Add PROFILES for CRITERIA.
 631 CRITERIA is a plist identifying a connection and the application
 632 using this connection, see `connection-local-criteria-alist'.
 633 PROFILES are the names of connection profiles (a symbol).
 634
 635 When a connection to a remote server is opened and CRITERIA
 636 matches to that server, the connection-local variables from
 637 PROFILES are applied to the corresponding process buffer.  The
 638 variables for a connection profile are defined using
 639 `connection-local-set-profile-variables'."
 640   (unless (listp criteria)
 641     (error "Wrong criteria `%s'" criteria))
 642   (dolist (profile profiles)
 643     (unless (assq profile connection-local-profile-alist)
 644       (error "No such connection profile `%s'" (symbol-name profile))))
 645   (let* ((criteria (connection-local-normalize-criteria criteria))
 646          (slot (assoc criteria connection-local-criteria-alist)))
 647     (if slot
 648         (setcdr slot (delete-dups (append (cdr slot) profiles)))
 649       (setq connection-local-criteria-alist
 650             (cons (cons criteria (delete-dups profiles))
 651                   connection-local-criteria-alist)))))
 652
 653 (defsubst connection-local-get-profile-variables (profile)
 654   "Return the connection-local variable list for PROFILE."
 655   (cdr (assq profile connection-local-profile-alist)))
 656
 657 ;;;###autoload
 658 (defun connection-local-set-profile-variables (profile variables)
 659   "Map the symbol PROFILE to a list of variable settings.
 660 VARIABLES is a list that declares connection-local variables for
 661 the connection profile.  An element in VARIABLES is an alist
 662 whose elements are of the form (VAR . VALUE).
 663
 664 When a connection to a remote server is opened, the server's
 665 connection profiles are found.  A server may be assigned a
 666 connection profile using `connection-local-set-profiles'.  Then
 667 variables are set in the server's process buffer according to the
 668 VARIABLES list of the connection profile.  The list is processed
 669 in order."
 670   (setf (alist-get profile connection-local-profile-alist) variables))
 671
 672 (defun hack-connection-local-variables (criteria)
 673   "Read connection-local variables according to CRITERIA.
 674 Store the connection-local variables in buffer local
 675 variable`connection-local-variables-alist'.
 676
 677 This does nothing if `enable-connection-local-variables' is nil."
 678   (when enable-connection-local-variables
 679     ;; Filter connection profiles.
 680     (dolist (profile (connection-local-get-profiles criteria))
 681       ;; Loop over variables.
 682       (dolist (variable (connection-local-get-profile-variables profile))
 683         (unless (assq (car variable) connection-local-variables-alist)
 684           (push variable connection-local-variables-alist))))))
 685
 686 ;;;###autoload
 687 (defun hack-connection-local-variables-apply (criteria)
 688  "Apply connection-local variables identified by CRITERIA.
 689 Other local variables, like file-local and dir-local variables,
 690 will not be changed."
 691  (hack-connection-local-variables criteria)
 692  (let ((file-local-variables-alist
 693         (copy-tree connection-local-variables-alist)))
 694    (hack-local-variables-apply)))
 695
 696 ;;;###autoload
 697 (defmacro with-connection-local-profiles (profiles &rest body)
 698   "Apply connection-local variables according to PROFILES in current buffer.
 699 Execute BODY, and unwind connection-local variables."
 700   (declare (indent 1) (debug t))
 701   `(let ((enable-connection-local-variables t)
 702          (old-buffer-local-variables (buffer-local-variables))
 703          connection-local-variables-alist connection-local-criteria-alist)
 704      (apply 'connection-local-set-profiles nil ,profiles)
 705      (hack-connection-local-variables-apply nil)
 706      (unwind-protect
 707          (progn ,@body)
 708        ;; Cleanup.
 709        (dolist (variable connection-local-variables-alist)
 710          (let ((elt (assq (car variable) old-buffer-local-variables)))
 711            (if elt
 712                (set (make-local-variable (car elt)) (cdr elt))
 713            (kill-local-variable (car variable))))))))
 714
 715 \f
 716
 717 (provide 'files-x)
 718
 719 ;;; files-x.el ends here