From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Michael Albinus Newsgroups: gmane.emacs.devel Subject: Re: git-handler.el Date: Fri, 11 Aug 2017 12:26:51 +0200 Message-ID: <87o9rmiems.fsf@detlef> References: <87eftk9uxe.fsf@bernoul.li> <87zic7ze06.fsf_-_@detlef> <87d192aold.fsf@bernoul.li> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: blaine.gmane.org 1502447237 27604 195.159.176.226 (11 Aug 2017 10:27:17 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Fri, 11 Aug 2017 10:27:17 +0000 (UTC) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.0.50 (gnu/linux) Cc: Emacs developers To: Jonas Bernoulli , Dmitry Gutov Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Fri Aug 11 12:27:12 2017 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1dg79p-0006bd-6F for ged-emacs-devel@m.gmane.org; Fri, 11 Aug 2017 12:27:09 +0200 Original-Received: from localhost ([::1]:55711 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dg79t-0007Jw-WB for ged-emacs-devel@m.gmane.org; Fri, 11 Aug 2017 06:27:14 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:57263) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dg79i-0007J6-CI for emacs-devel@gnu.org; Fri, 11 Aug 2017 06:27:03 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dg79f-0001cG-4y for emacs-devel@gnu.org; Fri, 11 Aug 2017 06:27:02 -0400 Original-Received: from mout.gmx.net ([212.227.15.19]:61421) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1dg79e-0001Yt-Cu for emacs-devel@gnu.org; Fri, 11 Aug 2017 06:26:59 -0400 Original-Received: from detlef.gmx.de ([213.220.148.96]) by mail.gmx.com (mrgmx001 [212.227.17.190]) with ESMTPSA (Nemesis) id 0LzKmP-1dbQKr2oc5-014WMz; Fri, 11 Aug 2017 12:26:52 +0200 In-Reply-To: <87d192aold.fsf@bernoul.li> (Jonas Bernoulli's message of "Fri, 14 Jul 2017 19:57:18 +0200") X-Provags-ID: V03:K0:AleSP9fIp4vyrFbMTpHmYD29HJTJrs8HoHagsAufTx7h+XiJRNm D6kOAW17G+YMhm4I3ShGq5EZ0qxg0p/kDgctUC1L2LJrLRRiOI7El1Z9pMGFIfEowLsAubi Cve9tca0nYhtIdp+qIU+3FxWtY5MKWf1+IhwsecaYejZd9KO5sO4LWpe+H2/PT4YQ6JCs3d 3h7Pz7nqJ/r/I8FphX7Ng== X-UI-Out-Filterresults: notjunk:1;V01:K0:RsLQtA2mhSE=:QOt40JV1bIu/bGzHl5X+0L 4JwgxjIkfFiXVKSyVEsap/zD2DTEU5Z7ivbhQEopFilPCizzhc5RojKeWlVx6YsheIbRdBLQ7 cnaNOlBtwuz0LNy4ITOSY619UoEf9EJeWj/L/lMXQMQx1dn6LwNV2alD83aozQ3u01cBIIIER nd2Hkc0OvN9aHoMOhgJh2NBo7+HdUn5314IeiD3XyK1LKNG2QldCYeAZaA7FT7vZdV7dhaz16 PghMXW7kP5znebtWjWSNMNIE8Nl4c2GaDwjPoxnnMNazx44r0RsofIHaGBrM8veUV0UPg7RQT 5tt6AJ18Se8X1MnKq3ag4BCdp5MXSpFOwmGUMZb+xN7QwaB93PtrvAAslDU5ofSWDoBscNHO+ OA8P29uPJV5egATSA9/hyNMJMD5YT0JqezuDDst4rNmBnVqifb+iz8mopEqDRoUFgzATX7xMY vkXSA2+P26496Je2jKF+qC5AxVxs1As/5cIs4X+4ninB7WoLwkhaTPuXrvtfoOMr4gK+1tBr9 4BPjZdvVM2nq8Q2BFcKnBvaox9QplSI8lHV1cXCcd+Yxowlc6FyJt9QRSeTKFeSFGJaXpJ/OR y/dq64KVjkKvOvAi7pYIqaO89h0tQudkroifoRY6tkDdPqi7J3oUbxOB2aYCYY/PZnexD3j4Q j2qos4q9INr1bjKBS1B3VtTWxDwG/CspnzY1TX/Hw/9CpllXpG92hqCoSUTMFkJM73DImXT0T lQzp7HF/0K88S8Ym7fwzSX7cRqRnNkMsOQsRa+aAqsJJ+uLOugId4vP6oSrLlinh5re/uTVU X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] [fuzzy] X-Received-From: 212.227.15.19 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.21 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.org gmane.emacs.devel:217425 Archived-At: --=-=-= Content-Type: text/plain Jonas Bernoulli 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. --=-=-= Content-Type: application/emacs-lisp; charset=utf-8 Content-Disposition: attachment; filename=vc-handler.el Content-Transfer-Encoding: quoted-printable ;;; 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 ;; 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 . ;;; 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--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-attribu= tes) (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-director= y) (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--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-nam= e)))) (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 predica= te) "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 _connect= ed) "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-suffi= x) "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 suff= ix))) (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 modifi= ed. (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: --=-=-= Content-Type: application/emacs-lisp; charset=utf-8 Content-Disposition: attachment; filename=vc-git-handler.el Content-Transfer-Encoding: quoted-printable ;;; 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 ;; 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 . ;;; 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=3D1" "--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 'intege= r)))) 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 recursio= n. (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=3D%h %at %an" "--max-count=3D1" 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 " 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=3D%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: --=-=-=--