From: Michael Albinus <michael.albinus@gmx.de>
To: Jonas Bernoulli <jonas@bernoul.li>, Dmitry Gutov <dgutov@yandex.ru>
Cc: Emacs developers <emacs-devel@gnu.org>
Subject: Re: git-handler.el
Date: Fri, 11 Aug 2017 12:26:51 +0200 [thread overview]
Message-ID: <87o9rmiems.fsf@detlef> (raw)
In-Reply-To: <87d192aold.fsf@bernoul.li> (Jonas Bernoulli's message of "Fri, 14 Jul 2017 19:57:18 +0200")
[-- Attachment #1: Type: text/plain, Size: 2127 bytes --]
Jonas Bernoulli <jonas@bernoul.li> writes:
> Hi Michael,
Hi Jonas, Dmitry,
>> The idea of writing a file name handler for versioned files is on my
>> todo list for years.
>
> Same here ;-) But I very much hope I get to it toward the end of August.
>
>> But I have 15 years experience in using file name handlers in Emacs. If
>> you need any help to write such a library, I would be glad to support
>> you. Just ping me, if you believe it could be useful.
>
> Thanks for the offer. I will contact you when I actually start working
> on this. If you get to it before I do, then please let me have a look,
> to make sure it satisfies Magit's needs.
As a warmup, I have written vc-handler.el and vc-git-handler.el. They
are far from being complete, but they'll show what's possible.
A revisioned filename is something like "/path/to/file@@revision".
"revision" could be a revision like "81656add81", a branch like
"scratch/kqueue", or a tag like "emacs-19.34". Of course, the syntax
could be changed.
vc-handler.el is the common part. There is the alist
`vc-file-name-handler-alist', which lists for every magic file name
function the responsible handler function. The majority of them is also
implemented in vc-handler.el, because they don't need any vcs specific
handling.
For every different backend, there could be a respective backend
package. I've implemented vc-git-handler.el, because I know more about
vc-git than magit. But there's no problem to implement vc-magit.el, for
example. I plan also to write at least vc-cvs.el.
You might play a little bit to see how it looks like. Maybe the most
simple start is to enter dired, because it uses many of the magic file
name operations. Just do "C-x d ~/src/emacs/src/emacs.c@@" (supposed
your Emacs git is located at ~/src/emacs, as in my case).
Both packages are far from being complete. Performance is terrible (a
proper cache mechanism is needed), my git skill is restricted so I might
not use the best commands, and you will see many TODO comments. It's
just a proof of concept. And I hope it is useful for both magit and vc.
> Jonas
Best regards, Michael.
[-- Attachment #2: vc-handler.el --]
[-- Type: application/emacs-lisp, Size: 21486 bytes --]
;;; 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 <michael.albinus@gmx.de>
;; 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)
"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)
"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)))
(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)
"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:
[-- Attachment #3: vc-git-handler.el --]
[-- Type: application/emacs-lisp, Size: 12566 bytes --]
;;; 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 <michael.albinus@gmx.de>
;; 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 respectice 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:
next prev parent reply other threads:[~2017-08-11 10:26 UTC|newest]
Thread overview: 136+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-07-05 15:29 In support of Jonas Bernoulli's Magit (was: comparing code on different branches) John Yates
2017-07-05 16:15 ` Kaushal Modi
2017-07-05 16:22 ` In support of Jonas Bernoulli's Magit Óscar Fuentes
2017-07-05 16:27 ` Kaushal Modi
2017-07-05 16:38 ` Stefan Monnier
2017-07-05 18:15 ` Óscar Fuentes
2017-07-05 23:03 ` Richard Stallman
2017-07-06 0:24 ` Clément Pit-Claudel
2017-07-06 1:46 ` Glenn Morris
2017-07-06 2:17 ` Clément Pit-Claudel
2017-07-10 9:26 ` Richard Stallman
2017-07-06 2:29 ` Jean-Christophe Helary
2017-07-14 14:34 ` Philippe Vaucher
2017-07-16 1:51 ` Richard Stallman
2017-07-06 1:50 ` Glenn Morris
2017-07-06 14:12 ` Ted Zlatanov
2017-07-06 14:47 ` Kaushal Modi
2017-07-06 17:11 ` Óscar Fuentes
2017-07-06 16:02 ` Richard Stallman
2017-07-06 16:52 ` Ken Manheimer
2017-07-07 18:23 ` Richard Stallman
2017-07-07 18:49 ` Stefan Monnier
2017-07-07 22:08 ` Phillip Lord
2017-07-07 22:22 ` Stefan Monnier
2017-07-08 6:58 ` Eli Zaretskii
2017-07-08 6:57 ` Eli Zaretskii
2017-07-08 9:05 ` Phillip Lord
2017-07-08 10:20 ` Eli Zaretskii
2017-07-08 20:34 ` Phillip Lord
2017-07-09 2:33 ` Eli Zaretskii
2017-07-10 9:28 ` Richard Stallman
2017-07-10 13:15 ` Phillip Lord
2017-07-11 11:45 ` Richard Stallman
2017-07-08 17:04 ` Richard Stallman
2017-07-08 20:52 ` Phillip Lord
2017-07-10 9:30 ` Richard Stallman
2017-07-08 17:02 ` Richard Stallman
2017-07-10 9:26 ` Richard Stallman
2017-07-10 12:47 ` Phillip Lord
2017-07-10 23:26 ` Richard Stallman
2017-07-11 9:40 ` Phillip Lord
2017-07-11 22:56 ` Richard Stallman
2017-07-10 23:27 ` Richard Stallman
2017-07-10 16:31 ` Marcin Borkowski
2017-07-10 23:30 ` Richard Stallman
2017-07-11 4:20 ` Marcin Borkowski
2017-07-11 11:48 ` Richard Stallman
2017-07-06 23:01 ` Dmitry Gutov
2017-07-07 18:27 ` Richard Stallman
2017-07-07 18:52 ` Stefan Monnier
2017-07-08 17:01 ` Richard Stallman
2017-07-08 17:42 ` raman
2017-07-08 18:58 ` Eli Zaretskii
2017-07-08 20:57 ` Phillip Lord
2017-07-08 22:57 ` John Yates
2017-07-09 0:04 ` raman
2017-07-09 9:25 ` Marcin Borkowski
2017-07-09 14:19 ` Eli Zaretskii
2017-07-10 1:01 ` In defense of VC [was: In support of Jonas Bernoulli's Magit] Juliusz Chroboczek
2017-07-10 7:09 ` Michael Albinus
2017-07-10 8:34 ` Lars Ingebrigtsen
2017-07-10 8:47 ` Juliusz Chroboczek
2017-07-10 8:59 ` Yuri Khan
2017-07-10 16:28 ` Marcin Borkowski
2017-07-10 17:12 ` Eli Zaretskii
2017-07-16 18:01 ` Dmitry Gutov
2017-07-16 19:09 ` Marcin Borkowski
2017-07-16 19:17 ` Dmitry Gutov
2017-07-10 23:26 ` Richard Stallman
2017-07-11 4:15 ` Marcin Borkowski
2017-07-11 11:48 ` Richard Stallman
2017-07-11 14:10 ` Marcin Borkowski
2017-07-11 14:27 ` Juliusz Chroboczek
2017-07-11 22:56 ` Richard Stallman
2017-07-11 14:37 ` Eli Zaretskii
2017-07-11 16:03 ` Dmitry Gutov
2017-07-11 7:10 ` Andreas Schwab
2017-07-11 7:26 ` Michael Albinus
2017-07-11 22:55 ` Richard Stallman
2017-07-10 9:29 ` In support of Jonas Bernoulli's Magit Richard Stallman
2017-07-10 16:32 ` Marcin Borkowski
2017-07-10 23:30 ` Richard Stallman
2017-07-11 4:14 ` Marcin Borkowski
2017-07-06 15:24 ` Phillip Lord
2017-07-10 9:26 ` Richard Stallman
2017-07-10 13:09 ` Phillip Lord
2017-07-11 11:45 ` Richard Stallman
2017-07-05 16:29 ` Stefan Monnier
2017-07-05 18:37 ` Ingo Lohmar
2017-07-05 18:14 ` In support of Jonas Bernoulli's Magit (was: comparing code on different branches) Noam Postavsky
2017-07-06 5:06 ` Paul Michael Reilly
2017-07-06 8:46 ` In support of Jonas Bernoulli's Magit Toon Claes
2017-07-07 1:38 ` Mike Gerwitz
2017-07-07 8:16 ` Trying out GitLab (was Re: In support of Jonas Bernoulli's Magit) Nicolas Petton
2017-07-07 8:27 ` Tino Calancha
2017-07-07 8:29 ` Nicolas Petton
2017-07-07 12:08 ` Ted Zlatanov
2017-07-08 11:02 ` Ævar Arnfjörð Bjarmason
2017-07-08 11:13 ` Dmitry Gutov
2017-07-08 11:53 ` Eli Zaretskii
2017-07-08 12:04 ` Dmitry Gutov
2017-07-08 21:02 ` Phillip Lord
2017-07-08 23:19 ` Tim Cross
2017-07-08 12:43 ` Ævar Arnfjörð Bjarmason
2017-07-08 12:54 ` Eli Zaretskii
2017-07-08 11:29 ` Jean-Christophe Helary
2017-07-07 16:55 ` Mike Gerwitz
2017-07-07 18:23 ` In support of Jonas Bernoulli's Magit Richard Stallman
2017-07-07 18:23 ` In support of Jonas Bernoulli's Magit (was: comparing code on different branches) Richard Stallman
2017-07-13 16:13 ` Jonas Bernoulli
2017-07-14 1:20 ` Richard Stallman
2017-07-14 18:24 ` Jonas Bernoulli
2017-07-14 3:31 ` In support of Jonas Bernoulli's Magit Stefan Monnier
2017-07-14 18:09 ` Jonas Bernoulli
2017-07-14 7:14 ` git-handler.el (was: In support of Jonas Bernoulli's Magit) Michael Albinus
2017-07-14 17:57 ` Jonas Bernoulli
2017-08-11 10:26 ` Michael Albinus [this message]
2017-08-12 10:48 ` git-handler.el Jonas Bernoulli
2017-08-12 12:01 ` git-handler.el Eli Zaretskii
2017-08-12 17:26 ` git-handler.el Jonas Bernoulli
2017-08-12 17:43 ` git-handler.el Eli Zaretskii
2017-08-12 19:32 ` git-handler.el Michael Albinus
2017-08-12 18:22 ` git-handler.el John Wiegley
2017-08-12 18:28 ` git-handler.el Michael Albinus
2017-08-12 19:52 ` git-handler.el Jonas Bernoulli
2017-08-13 9:26 ` git-handler.el Michael Albinus
2017-08-12 19:17 ` git-handler.el Michael Albinus
2017-08-12 19:46 ` git-handler.el Yuri Khan
2017-08-13 9:14 ` git-handler.el Michael Albinus
2017-08-13 10:08 ` git-handler.el Yuri Khan
2017-08-13 14:31 ` git-handler.el Eli Zaretskii
2017-08-13 15:08 ` git-handler.el Yuri Khan
2017-08-13 15:26 ` git-handler.el Eli Zaretskii
2017-08-14 16:42 ` git-handler.el Michael Albinus
2017-08-14 16:40 ` git-handler.el Michael Albinus
2017-07-10 16:16 ` In support of Jonas Bernoulli's Magit (was: comparing code on different branches) Filipe Silva
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87o9rmiems.fsf@detlef \
--to=michael.albinus@gmx.de \
--cc=dgutov@yandex.ru \
--cc=emacs-devel@gnu.org \
--cc=jonas@bernoul.li \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.