all messages for Emacs-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
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:

  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.