Peter Marinov <[email protected]> writes: > Hello at tramp-devel,
Hi Peter, > I've implemented a method of accessing the file tree behind a given > git hash. Interesting. > It works in this format, for example: > > /git:5e7a71d:/home/peterm/work/emacs > > This will open a dired viewer of the repo, entering folders or viewing > files keeps the initial hash. Why to restrict yourself to the dired viewer? If you implement this with file name handlers, you shall have all possible functions in mind. > To try it quickly: > > $ git clone https://git.sr.ht/~pem/git-tramp > $ cd git-tramp > $ emacs -nw -l git-tramp.el I've tried it shortly, but it didn't work for me. Perhaps it is in an early stage. > My ultimate plan is for this to be integrated with > 'vc-print-root-log'. Where now we can do '=' to see a diff, or RET to > see the commit comment, I would like to add 't' to invoke git-tramp > over that hash in the log. Well, I'm not sure whether it is what users need this way. I would rather expect a syntax which gives first the file name, and after that the git hash. This is more convenient when you want to compare different versions of the same file. > I'm writing to ask your help with a question: > > In 'defconst git-tramp-file-name-handler-alist' we have a table of > key/value pairs that hooks implementations of functions in the Tramp > engine. > > I wasn't sure what is the full format of the table, furthermore, what > is the full range of methods that required implementation? This is a format like ((func1 . impl1) (func2 . impl2) ... (funcN . implN)) func<i> is a basic Lisp operation, and impl<i> is the implementation which is used instead. The full range of operations is listed in the Emacs Lisp manual, see (info "(elisp) Magic File Names") . > Any additional comments or suggestions are welcome. I don't believe you must base your implamentation on Tramp. All what you need is proper handling of a file name handler. Some years ago, I wrote something similar called 'vc-handler'. The idea was to support a file name syntax like "/path/to/file@@/branch/revision-or-label". You see that the resivision (hash in the git case) and the branch come after the file name. The package 'vc-git-handler' was the backend for git; I didn't implement it for other VCS backends. Well, it worked to some extend. But I gave up, because the performance was miserable, and I'm not such a git aficionado that I could tune it. I'll append both files for your amusement. You can try it like this: --8<---------------cut here---------------start------------->8--- # emacs -Q -L ~/lisp -l vc-handler ;; My private Lisp files reside in ~/lisp C-x C-f ~/src/git-tramp/ ;; This is your checked out repo C-x C-f git-t TAB ;; Expands to ~/src/git-tramp/git-tramp.el @@/ TAB ;; Expands to { HEAD | master/ } mas TAB ;; Expands to { 07db2bd | 1196543 | 2b9edd5 | ... } 07db2bd RET ;; Here we are. --8<---------------cut here---------------end--------------->8--- 8 years old; I'm pretty sure there are missing parts. If you open just ~/src/git-tramp/git-tramp.el@@/master, you'll see a dired listing with the revisions as "file names". You can use them as such, for exampl do a diff over them, or copy them out of this virtual directory. > Regards, > Peter M. Best regards, Michael.
;;; vc-handler.el --- File Name Handler for revisions of version controlled files -*- lexical-binding:t -*- ;; Copyright (C) 2017 Free Software Foundation, Inc. ;; Author: Michael Albinus <[email protected]> ;; Keywords: vc tools ;; Package: vc ;; 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 package provides transparent access to revisions of version ;; controlled files. A revision looks always like ;; "/path/to/file@@/branch/revision-or-label". The ;; "@@/branch/revision-or-label" syntax depends on the used vc ;; backend. ;; All files or directories with this syntax are handled read-only. ;; It is not intended to modify revisions of such files or ;; directories. ;; For Git, a revision looks like "@@/master/ef7a18a071" or ;; "@@/master/HEAD". A branch might be "@@/emacs-25/3a34412caa" or ;; "@@/emacs-25/HEAD", and a label is "@@/emacs-25.2" ;; For Cvs, it looks like "@@/2.7" or "@@/V-2-2-6" (a label) or ;; "@@/branch-2-1-stable/2.7.0.2" (a branch). ;; Revisioned file names, which are not complete until the final ;; revision number or label, are regarded as directories. Files in ;; that directory are the respective revisions. A directory ;; "@@/emacs-25/" might contain the files "3a34412caa" or ;; "56a4461a48". ;; File name handlers for a magic file operation are declared in ;; `vc-file-name-handler-alist' and vc backend specific ;; `vc-<backend>-file-name-handler-alist' variables. If a file name ;; handler is declared in both locations, the backend specific one ;; takes precedence. If no file name handler is declared, the default ;; operation is applied. ;;; Code: (require 'vc) ;; TODO: This is just temporarily. (require 'ls-lisp) (setq ls-lisp-use-insert-directory-program nil enable-dir-local-variables nil) (defconst vc-file-name-regexp "@@[-[:alnum:]._/]*\\'" "Regular expression matching revisioned file names.") ;; New handlers should be added here. (defconst vc-file-name-handler-alist '(;; `access-file' performed by default handler. (add-name-to-file . ignore) ;; `byte-compiler-base-file-name' performed by default handler. ;; `copy-directory' performed by default handler. (copy-file . vc-handle-copy-file) (delete-directory . ignore) (delete-file . ignore) ;; `diff-latest-backup-file' performed by default handler. ;; `directory-file-name' performed by default handler. (directory-files . vc-handle-directory-files) (directory-files-and-attributes . vc-handle-directory-files-and-attributes) (dired-compress-file . ignore) ;; `dired-uncache' performed by default handler. (expand-file-name . vc-handle-expand-file-name) (file-accessible-directory-p . vc-handle-file-accessible-directory-p) (file-acl . ignore) (file-attributes . vc-handle-file-attributes) (file-directory-p . vc-handle-file-directory-p) ;; `file-equal-p' performed by default handler. (file-executable-p . vc-handle-file-executable-p) (file-exists-p . vc-handle-file-exists-p) ;; `file-in-directory-p' performed by default handler. ;; `file-local-copy' performed by backend specific handler. (file-modes . vc-handle-file-modes) ;; `file-name-all-completions' performed by backend specific handler. ;; `file-name-as-directory' performed by default handler. (file-name-case-insensitive-p . vc-handle-file-name-case-insensitive-p) (file-name-completion . vc-handle-file-name-completion) ;; `file-name-directory' performed by default handler. ;; `file-name-nondirectory' performed by default handler. ;; `file-name-sans-versions' performed by default handler. (file-newer-than-file-p . vc-handle-file-newer-than-file-p) (file-notify-add-watch . ignore) (file-notify-rm-watch . ignore) (file-notify-valid-p . ignore) (file-ownership-preserved-p . ignore) (file-readable-p . vc-handle-file-readable-p) (file-regular-p . vc-handle-file-regular-p) (file-remote-p . vc-handle-file-remote-p) (file-selinux-context . ignore) (file-symlink-p . vc-handle-file-symlink-p) (file-truename . vc-handle-file-truename) (file-writable-p . ignore) ;; `find-backup-file-name' performed by default handler. ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. (insert-directory . vc-handle-insert-directory) (insert-file-contents . vc-handle-insert-file-contents) (load . vc-handle-load) (make-auto-save-file-name . ignore) (make-directory . ignore) (make-nearby-temp-file . vc-handle-make-nearby-temp-file) (make-symbolic-link . ignore) (process-file . vc-handle-process-file) ;; `rename-file' performed by default handler. (set-file-acl . ignore) (set-file-modes . ignore) (set-file-selinux-context . ignore) (set-file-times . ignore) (set-visited-file-modtime . ignore) (shell-command . ignore) (start-file-process . ignore) (substitute-in-file-name . vc-handle-substitute-in-file-name) ;; `temporary-file-directory' performed by default handler. (unhandled-file-name-directory . vc-handle-unhandled-file-name-directory) (vc-registered . ignore) (verify-visited-file-modtime . vc-handle-verify-visited-file-modtime) (write-region . ignore)) "Alist of handler functions. Operations not mentioned here will be handled by the normal Emacs functions.") (defun vc-handler-file-name-p (file) "Check, whether FILE is a revisioned file name" (and (stringp file) (string-match vc-file-name-regexp file))) (defun vc-handler-file-name-part (file) "Return the regular name of FILE, without the revision part." (if (vc-handler-file-name-p file) (replace-match "" nil nil file) file)) (defun vc-handler-file-revision-name (file) "Return the revision of FILE, if any." (when (vc-handler-file-name-p file) (match-string 0 file))) (defun vc-responsible-handler (operation args) "Determine the responsible handler for file name operation ARGS. One of the elements in ARGS must be a revisioned file name. This function checks first whether there is a backend specific handler, by inspectiong `vc-<backend>-file-name-handler-alist'. If none is found, `vc-file-name-handler-alist' is inspected." ;; Check which element of ARGS is a revisioned file name. (setq args (append args `(,default-directory))) (while (and (consp args) (not (vc-handler-file-name-p (car args)))) (setq args (cdr args))) ;; Search backend specific handler. (when (consp args) (let* ((default-directory temporary-file-directory) ;; Avoid recursion. (responsible-backend ;; This check is restricted to `vc-handled-backends'. But ;; this could be extended to other backends easily, like ;; magit. (ignore-errors (vc-responsible-backend (vc-handler-file-name-part (car args))))) (package (and responsible-backend (concat "vc-" (downcase (symbol-name responsible-backend)) "-handler"))) (backend-handler-alist (and responsible-backend (intern (concat "vc-" (downcase (symbol-name responsible-backend)) "-file-name-handler-alist"))))) (or (and package (or (featurep (intern package)) (load package 'noerror 'nomessage)) backend-handler-alist (boundp backend-handler-alist) (assoc operation (symbol-value backend-handler-alist))) (assoc operation vc-file-name-handler-alist))))) (defun vc-run-real-handler (operation args) "Invoke normal file name handler for OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." (let* ((inhibit-file-name-handlers `(vc-file-name-handler . ,(and (eq inhibit-file-name-operation operation) inhibit-file-name-handlers))) (inhibit-file-name-operation operation)) (apply operation args))) (defun vc-file-name-handler (operation &rest args) "Invoke revisioned file name handler. Falls back to normal file name handler if it doesn't exists." (let ((fn (vc-responsible-handler operation args))) (if fn (save-match-data (apply (cdr fn) args)) (vc-run-real-handler operation args)))) ;; Activate the handler. (add-to-list 'file-name-handler-alist (cons vc-file-name-regexp 'vc-file-name-handler)) (put 'vc-file-name-handler 'safe-magic t) ;; Mark `operations' the handler is responsible for. (put 'vc-file-name-handler 'operations (cl-union (get 'vc-file-name-handler 'operations) (mapcar 'car vc-file-name-handler-alist))) ;; The handlers. (defun vc-handle-copy-file (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for revisioned files." (setq filename (expand-file-name filename) newname (expand-file-name newname)) (if (vc-handler-file-name-p filename) (rename-file (file-local-copy filename) newname ok-if-already-exists) (vc-run-real-handler 'copy-file (list filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)))) (defun vc-handle-directory-files (directory &optional full match nosort _count) "Like `directory-files' for revisioned files." (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (let ((temp (nreverse (file-name-all-completions "" directory))) result item) (while temp (setq item (directory-file-name (pop temp))) (when (or (null match) (string-match match item)) (push (if full (concat directory item) item) result))) (if nosort result (sort result 'string<))))) (defun vc-handle-directory-files-and-attributes (directory &optional full match nosort id-format count) "Like `directory-files-and-attributes' for revisioned files." (mapcar (lambda (x) (cons x (file-attributes (if full x (expand-file-name x directory)) id-format))) (directory-files directory full match nosort count))) (defun vc-handle-expand-file-name (filename &optional dir) "Like `expand-file-name' for revisioned files." (if (not (file-name-absolute-p filename)) (expand-file-name (concat (file-name-as-directory (or dir default-directory)) filename)) (let* ((default-directory (or dir default-directory)) (revision-name (or (vc-handler-file-revision-name filename) ));(vc-handler-file-revision-name default-directory))) (default-directory (unhandled-file-name-directory default-directory))) (when (and revision-name (string-equal (file-name-nondirectory revision-name) ".")) (setq revision-name (file-name-directory revision-name))) (concat (expand-file-name (vc-handler-file-name-part filename)) revision-name)))) (defun vc-handle-file-accessible-directory-p (filename) "Like `file-accessible-directory-p' for revisioned files." (and (file-directory-p filename) (file-readable-p filename))) (defun vc-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for revisioned files." ;; This is the default implementation. Shall be superseded by ;; backend specific specific implementation. Time, owner, branches ;; being directories, ... (let ((default-directory (unhandled-file-name-directory default-directory))) (file-attributes (vc-handler-file-name-part filename) id-format))) (defun vc-handle-file-directory-p (filename) "Like `file-directory-p' for revisioned files." (eq (car (file-attributes filename)) t)) (defun vc-handle-file-executable-p (filename) "Like `file-executable-p' for revisioned files." (or (file-directory-p filename) (file-executable-p (vc-handler-file-name-part filename)))) (defun vc-handle-file-exists-p (filename) "Like `file-exists-p' for revisioned files." (not (null (file-attributes filename)))) ;; This function is stolen from `tramp-mode-string-to-int'. Maybe a ;; common Emacs function would serve? (defun vc-handler-mode-string-to-int (mode-string) "Converts a ten-letter `drwxrwxrwx'-style mode string into mode bits." (let* (case-fold-search (mode-chars (string-to-vector mode-string)) (owner-read (aref mode-chars 1)) (owner-write (aref mode-chars 2)) (owner-execute-or-setid (aref mode-chars 3)) (group-read (aref mode-chars 4)) (group-write (aref mode-chars 5)) (group-execute-or-setid (aref mode-chars 6)) (other-read (aref mode-chars 7)) (other-write (aref mode-chars 8)) (other-execute-or-sticky (aref mode-chars 9))) (save-match-data (logior (cond ((char-equal owner-read ?r) (string-to-number "00400" 8)) ((char-equal owner-read ?-) 0) (t (error "Second char `%c' must be one of `r-'" owner-read))) (cond ((char-equal owner-write ?w) (string-to-number "00200" 8)) ((char-equal owner-write ?-) 0) (t (error "Third char `%c' must be one of `w-'" owner-write))) (cond ((char-equal owner-execute-or-setid ?x) (string-to-number "00100" 8)) ((char-equal owner-execute-or-setid ?S) (string-to-number "04000" 8)) ((char-equal owner-execute-or-setid ?s) (string-to-number "04100" 8)) ((char-equal owner-execute-or-setid ?-) 0) (t (error "Fourth char `%c' must be one of `xsS-'" owner-execute-or-setid))) (cond ((char-equal group-read ?r) (string-to-number "00040" 8)) ((char-equal group-read ?-) 0) (t (error "Fifth char `%c' must be one of `r-'" group-read))) (cond ((char-equal group-write ?w) (string-to-number "00020" 8)) ((char-equal group-write ?-) 0) (t (error "Sixth char `%c' must be one of `w-'" group-write))) (cond ((char-equal group-execute-or-setid ?x) (string-to-number "00010" 8)) ((char-equal group-execute-or-setid ?S) (string-to-number "02000" 8)) ((char-equal group-execute-or-setid ?s) (string-to-number "02010" 8)) ((char-equal group-execute-or-setid ?-) 0) (t (error "Seventh char `%c' must be one of `xsS-'" group-execute-or-setid))) (cond ((char-equal other-read ?r) (string-to-number "00004" 8)) ((char-equal other-read ?-) 0) (t (error "Eighth char `%c' must be one of `r-'" other-read))) (cond ((char-equal other-write ?w) (string-to-number "00002" 8)) ((char-equal other-write ?-) 0) (t (error "Ninth char `%c' must be one of `w-'" other-write))) (cond ((char-equal other-execute-or-sticky ?x) (string-to-number "00001" 8)) ((char-equal other-execute-or-sticky ?T) (string-to-number "01000" 8)) ((char-equal other-execute-or-sticky ?t) (string-to-number "01001" 8)) ((char-equal other-execute-or-sticky ?-) 0) (t (error "Tenth char `%c' must be one of `xtT-'" other-execute-or-sticky))))))) (defun vc-handle-file-modes (filename &optional _flag) "Like `file-modes' for revisioned files." (let ((truename (or (file-truename filename) filename))) (when (file-exists-p truename) (vc-handler-mode-string-to-int (file-attribute-modes (file-attributes truename)))))) (defun vc-handle-file-name-case-insensitive-p (filename) "Like `file-name-case-insensitive-p' for revisioned files." (let ((default-directory (unhandled-file-name-directory default-directory))) (file-name-case-insensitive-p (vc-handler-file-name-part filename)))) (defun vc-handle-file-name-completion (filename directory &optional predicate) "Like `file-name-completion' for revisioned files." (let (hits-ignored-extensions) (or (try-completion filename (file-name-all-completions filename directory) (lambda (x) (when (funcall (or predicate 'identity) (expand-file-name x directory)) (not (and completion-ignored-extensions (string-match (concat (regexp-opt completion-ignored-extensions 'paren) "$") x) ;; We remember the hit. (push x hits-ignored-extensions)))))) ;; No match. So we try again for ignored files. (try-completion filename hits-ignored-extensions)))) (defun vc-handle-file-newer-than-file-p (file1 file2) "Like `file-newer-than-file-p' for revisioned files." (cond ((not (file-exists-p file1)) nil) ((not (file-exists-p file2)) t) (t (time-less-p (file-attribute-modification-time (file-attributes file2)) (file-attribute-modification-time (file-attributes file1)))))) (defalias 'vc-handle-file-readable-p 'vc-handle-file-exists-p "Like `file-readable-p' for revisioned.") (defun vc-handle-file-regular-p (filename) "Like `file-regular-p' for revisioned files." (and (file-exists-p filename) (eq ?- (aref (file-attribute-modes (file-attributes filename)) 0)))) ;; Of course, no revisioned file is remote per se. But packages use ;; `file-remote-p' as indication, whether a file name could be used ;; literally. So we return a non-nil value for handled file names. (defun vc-handle-file-remote-p (filename &optional _identification _connected) "Like `file-remote-p' for revisioned files." (vc-handler-file-name-part filename)) (defun vc-handle-file-symlink-p (filename) "Like `file-symlink-p' for revisioned files." (let ((x (file-attribute-type (file-attributes filename)))) (and (stringp x) x))) (defun vc-handle-file-truename (filename) "Like `file-truename' for revisioned files." (if (file-symlink-p filename) (file-truename (concat (vc-handler-file-name-part filename) "@@/" (file-symlink-p filename))) (concat (file-truename (vc-handler-file-name-part filename)) (vc-handler-file-revision-name filename)))) (defun vc-handle-insert-directory (filename switches &optional wildcard full-directory-p) "Like `insert-directory' for versioned files." (unless switches (setq switches "")) ;; Mark trailing "/". (when (and (zerop (length (file-name-nondirectory filename))) (not full-directory-p)) (setq switches (concat switches "F"))) (require 'ls-lisp) (let (ls-lisp-use-insert-directory-program start) (vc-run-real-handler 'insert-directory (list filename switches wildcard full-directory-p)))) (defun vc-handle-insert-file-contents (filename &optional visit beg end replace) "Like `insert-file-contents' for revisioned files." (let* ((tmpfile (file-local-copy (file-truename filename))) (result (insert-file-contents tmpfile visit beg end replace))) (when visit (setq buffer-file-name filename) (setq buffer-read-only (not (file-writable-p filename))) (set-visited-file-modtime) (set-buffer-modified-p nil)) (delete-file tmpfile) (list (expand-file-name filename) (cadr result)))) (defun vc-handle-load (file &optional noerror nomessage nosuffix must-suffix) "Like `load' for revisioned files." (load (file-local-copy file) noerror nomessage nosuffix must-suffix)) (defun vc-handle-make-nearby-temp-file (prefix &optional dir-flag suffix) "Like `make-nearby-temp-file' for revisioned files." (let ((default-directory (unhandled-file-name-directory default-directory))) (make-nearby-temp-file (vc-handler-file-name-part prefix) dir-flag suffix))) (defun vc-handle-process-file (program &optional infile buffer display &rest args) "Like `process-file' for revisioned files." (let ((default-directory (unhandled-file-name-directory default-directory))) (unless (file-directory-p default-directory) (setq default-directory (file-name-directory (directory-file-name default-directory)))) (apply 'process-file program infile buffer display args))) (defun vc-handle-substitute-in-file-name (filename) "Like `substitute-in-file-name' for revisioned files." (concat (substitute-in-file-name (vc-handler-file-name-part filename)) (vc-handler-file-revision-name filename))) (defun vc-handle-verify-visited-file-modtime (&optional buf) "Like `verify-visited-file-modtime' for revisioned files." ;; Since all files are read-only, we check whether buffer has been modified. (not (buffer-modified-p (or buf (current-buffer))))) (defun vc-handle-unhandled-file-name-directory (filename) "Like `unhandled-file-name-directory' for revisioned files." (vc-handler-file-name-part filename)) ;; Debug. (dolist (elt (all-completions "vc-handle-" obarray 'functionp)) (trace-function-background (intern elt))) (provide 'vc-handler) ;;; vc-handler.el ends here ;; Local Variables: ;; mode: Emacs-Lisp ;; coding: utf-8 ;; End:
;;; vc-git-handler.el --- File Name Handler for revisions of Git versioned files -*- lexical-binding:t -*- ;; Copyright (C) 2017 Free Software Foundation, Inc. ;; Author: Michael Albinus <[email protected]> ;; Keywords: vc tools ;; Package: vc ;; 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 package provides file name handlers specific for Git. ;; A revision looks like "@@/master/ef7a18a071" or "@@/master/HEAD". ;; Branches are subdirectories, a revision in a branch might be ;; "@@/emacs-25/3a34412caa" or "@@/emacs-25/HEAD", and a label is a ;; symlink like "@@/emacs-25.2". The element "HEAD" is always a ;; symlink to either the head of a branch, or to the current branch on ;; top level. ;;; Code: (require 'vc-git) ;; New handlers should be added here. (defconst vc-git-file-name-handler-alist '((file-attributes . vc-git-handle-file-attributes) (file-name-all-completions . vc-git-handle-file-name-all-completions) ;; TODO: Wouldn't it be better, to have `copy-file' here? (file-local-copy . vc-git-handle-file-local-copy)) "Alist of Git specific handler functions. Operations not mentioned here will be handled by vc-handler.el or the default file name functions.") ;; Mark `operations' the handler is responsible for. (put 'vc-file-name-handler 'operations (cl-union (get 'vc-file-name-handler 'operations) (mapcar 'car vc-git-file-name-handler-alist))) ;; Internal variables and functions. (defvar vc-git-handler-branches nil "Cached local branch names. The car of the list is the current branch.") (defun vc-git-handler-branches () "Return a list of local branches. The car of the list is the current branch." (setq vc-git-handler-branches (vc-git-branches))) (defvar vc-git-handler-tags nil "Cached tag names.") (defun vc-git-handler-tags () "Return a list of all tags." (setq vc-git-handler-tags (or vc-git-handler-tags (split-string (vc-git--run-command-string nil "tag") nil 'omit-nulls)))) (defvar vc-git-handler-heads nil "Cached alist of (OBJECT SHA1) tupels. OBJECT is a branch name, a tag name, or \"HEAD\".") (defun vc-git-handler-heads () "Return an alist (OBJECT SHA1) tupels. OBJECT is a branch name, a tag name, or \"HEAD\"." (setq vc-git-handler-heads (or vc-git-handler-heads (mapcar (lambda (x) (list (replace-regexp-in-string "refs/\\(tags\\|heads\\)/" "" (cadr x)) (car x))) (mapcar ;; Hash object. 'split-string ;; Lines. (split-string (vc-git--run-command-string nil "show-ref" "--heads" "--tags" "--head" "--abbrev") "[\f\n]+" 'omit-nulls)))))) (defun vc-git-handler-head (object) "Return SHA1 of OBJECT. OBJECT is a branch name, a tag name, or \"HEAD\"." (cadr (assoc object (vc-git-handler-heads)))) (defvar vc-git-handler-file-attributes (make-hash-table :test 'equal) "Cached file attributes. It is a hash, the key is the revisioned file name, and the value is the result of `file-attributes'.") ;; TODO: We shall add also functions to expire the caches. Best would ;; be file notification, which watches respective git files (indexes). (defun vc-git-handler-object-exists-for-file-p (object filename) "Check, whether OBJECT (branch or tag) exists for FILE." ;; This is a sledge-hammer approach. There must be something more ;; efficient. For the time being, we simply return t. ;; (not ;; (zerop ;; (length ;; (vc-git--run-command-string ;; (vc-handler-file-name-part filename) ;; "log" "--max-count=1" "--oneline" object "--"))))) t) ;; The handlers. (defun vc-git-handler-file-attributes-of-head (filename &optional id-format) "Like `file-attributes' for HEAD." (setq filename (expand-file-name filename)) (let* ((file-name (vc-handler-file-name-part filename)) (revision (vc-handler-file-revision-name filename)) attr) ;; Revision is @@/branch/name/HEAD. (string-match "\\`@@\\(?:/\\(.*\\)\\)?/HEAD\\'" revision) (setq revision (match-string 1 revision) attr (file-attributes (concat file-name "@@/" (vc-git-handler-head (or revision "HEAD"))) id-format)) ;; Modify symlink. (if (zerop (length revision)) (setcar attr (car (vc-git-handler-branches))) ;; Current branch. (setcar attr (vc-git-handler-head revision))) ;; Head of branch. (aset (nth 8 attr) 0 ?l) attr)) (defun vc-git-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for revisioned files." (let ((cache-key (concat filename "@@" (symbol-name (or id-format 'integer)))) attr) (cond ;; Cached value. ((setq attr (gethash cache-key vc-git-handler-file-attributes))) ;; Determine HEAD. ((string-equal (file-name-nondirectory filename) "HEAD") (setq attr (vc-git-handler-file-attributes-of-head filename id-format))) (t (setq filename (expand-file-name filename)) (let* ((default-directory temporary-file-directory) ;; Avoid recursion. (file-name (vc-handler-file-name-part filename)) (root (vc-git-root file-name)) (default-directory (expand-file-name root)) (revision (vc-handler-file-revision-name filename)) git-log hash time author) (setq attr (file-attributes file-name id-format)) ;; Determine revision. (string-match "\\`@@/\\(.+\\)\\'" revision) (when (and (setq revision (match-string 1 revision)) ;; It could be branch/name/nnnnnnnnnn. (file-name-directory revision) (member (directory-file-name (file-name-directory revision)) (vc-git-handler-branches))) (setq revision (file-name-nondirectory revision) revision (unless (zerop (length revision)) revision))) ;; Determine hash, commit time and commit author. (ignore-errors (when (and (setq git-log (vc-git--run-command-string (unless (member revision (vc-git-handler-tags)) file-name) "log" "--no-color" "--format=%h %at %an" "--max-count=1" revision "--")) (string-match (concat "\\`\\([[:alnum:]]+\\)[[:space:]]" "\\([[:digit:]]+\\)[[:space:]]" "\\(.+\\)\n?\\'") git-log)) (setq hash (match-string 1 git-log) time (string-to-number (match-string 2 git-log)) author (match-string 3 git-log)))) ;; Modify directory indicator. (when (or (null revision) (member revision (vc-git-handler-branches))) (setcar attr t) (aset (nth 8 attr) 0 ?d)) ;; Modify symlink. (when (member revision (vc-git-handler-tags)) (setcar attr hash) (aset (nth 8 attr) 0 ?l)) ;; Modify uid and gid string. (when (and author (eq id-format 'string)) (setcar (nthcdr 2 attr) author) (setcar (nthcdr 3 attr) "UNKNOWN")) ;; Modify last access time, last modification time, and last ;; status change time. (when time (setcar (nthcdr 4 attr) (list (floor time 65536) (floor (mod time 65536)))) (setcar (nthcdr 5 attr) (list (floor time 65536) (floor (mod time 65536)))) (setcar (nthcdr 6 attr) (list (floor time 65536) (floor (mod time 65536))))) ;; Modify file size. (ignore-errors (and revision (setq git-log (vc-git--run-command-string nil "cat-file" "-s" (format "%s:%s" revision (file-relative-name file-name)))) (string-match "\\`\\([[:digit:]]+\\)\n?\\'" git-log) (setcar (nthcdr 7 attr) (string-to-number (match-string 1 git-log))))) ;; Modify mode string. Remove write bit, and add execute bit ;; for directories. (aset (nth 8 attr) 2 ?-) (aset (nth 8 attr) 5 ?-) (aset (nth 8 attr) 8 ?-) (when (char-equal (aref (nth 8 attr) 0) ?d) (when (char-equal (aref (nth 8 attr) 1) ?r) (aset (nth 8 attr) 3 ?x)) (when (char-equal (aref (nth 8 attr) 4) ?r) (aset (nth 8 attr) 6 ?x)) (when (char-equal (aref (nth 8 attr) 7) ?r) (aset (nth 8 attr) 9 ?x)))))) ;; TODO: we need also to modify inode, device-number. ;; Result. (puthash cache-key attr vc-git-handler-file-attributes))) ;; This function should return "foo/" for directories and "bar" for files. (defun vc-git-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for revisioned files." (let* ((file-name (vc-handler-file-name-part directory)) (branch (vc-handler-file-revision-name directory)) (default-directory (unhandled-file-name-directory file-name)) base all-revisions all-tags all-branches) (unless (file-directory-p default-directory) (setq default-directory (file-name-directory (directory-file-name default-directory)))) ;; Read branch specific revisions. ;; TODO: This yields all revisions reachable from the branch head. ;; It might be better to return only revisions starting when the ;; branch was created, but I don't know how to determine this. ;; "git merge-base --fork-point <branch>" sounds like a good ;; candidate, but it doesn't work as expected. (string-match "\\`@@/\\(.+\\)\\'" branch) (when (and (setq branch (match-string 1 branch)) (setq branch (directory-file-name branch))) (ignore-errors (with-temp-buffer (and (vc-git-command (current-buffer) nil file-name "log" "--no-color" "--format=%h" branch "--") (goto-char (point-min)) (while (< (point) (point-max)) (push (buffer-substring-no-properties (point) (line-end-position)) all-revisions) (forward-line 1)))))) ;; Every branch has a virtual HEAD. (setq all-revisions (cons "HEAD" all-revisions)) ;; Read tags. (setq all-tags (mapcar (lambda (x) (and (if branch ;; Mention only tags belonging to branch. (member (vc-git-handler-head x) all-revisions) ;; All existing tags for that file. (vc-git-handler-object-exists-for-file-p x file-name)) x)) (vc-git-handler-tags))) ;; Read branches in top level for that file. Add trailing "/". (unless branch (setq all-branches (mapcar (lambda (x) (and (vc-git-handler-object-exists-for-file-p x file-name) (file-name-as-directory x))) (vc-git-handler-branches)))) ;; Result. (all-completions filename (delq nil (append all-revisions all-tags all-branches))))) (defun vc-git-handle-file-local-copy (filename) "Like `file-local-copy' for revisioned files." (setq filename (expand-file-name filename)) (let* ((default-directory temporary-file-directory) ;; Avoid recursion. (file-name (vc-handler-file-name-part filename)) (root (vc-git-root file-name)) (default-directory (expand-file-name root)) (revision (vc-handler-file-revision-name filename)) (result (make-temp-file "vc-" nil (file-name-extension file-name 'period)))) ;; Determine revision. (string-match "\\`@@/\\(.+\\)\\'" revision) (when (setq revision (match-string 1 revision)) (setq revision (file-name-nondirectory revision)) (with-temp-buffer (and (vc-git-command (current-buffer) nil nil "show" (format "%s:%s" revision (file-relative-name file-name))) (write-region nil nil result))) ;; Set attributes. (set-file-times result (file-attribute-modification-time (file-attributes filename))) (set-file-modes result (file-modes filename)) result))) ;; Debug. (dolist (elt (all-completions "vc-git-" obarray 'functionp)) (trace-function-background (intern elt))) (provide 'vc-git-handler) ;;; vc-git-handler.el ends here ;; Local Variables: ;; mode: Emacs-Lisp ;; coding: utf-8 ;; End:
