vc-pijul.el
;;; vc-pijul.el --- a VC backend for Pijul -*- lexical-binding: t -*-
;;; Copyright (C) 2004 Jorgen Schaefer <forcer@forcix.cx>
;;; Copyright (C) 2004-2014 Juliusz Chroboczek <jch@pps.univ-paris-diderot.fr>
;;; Copyright (C) 2022 Greg Pfeil <greg@techhnomadic.org>
;; Author: Jorgen Schaefer <forcer@forcix.cx>
;; Juliusz Chroboczek <jch@pps.univ-paris-diderot.fr>
;; Greg Pfeil <greg@techhnomadic.org>
;; Maintainer: Greg Pfeil <greg@techhnomadic.org>
;; Keywords: vc
;; Package-Version: 20220926.2130
;; Package-X-Original-Version: 20141122.1326
;; Version: 0.1
;; Package-Requires: ((emacs "24"))
;;; This program 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.
;;; This program 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 this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;;; 02111-1307, USA.
;;; Commentary:
;; Pijul is a distributed version control system, available at
;; http://www.pijul.net/
;; This version of vc-pijul was tested with Emacs 28. It might still work on
;; Emacs 24, but it currently uses features that aren’t available prior to
;; that.
;; A few ideas for this file are directly taken from vc-svn.el. Thanks to
;; Jim Blandy. This file has been forked from vc-darcs.el. Thanks to Jorgen
;; Schaefer, Juliusz Chroboczek, and Libor Čapák <capak@inputwish.com>.
;; To install, put this file into your load-path and add the following to
;; your emacs init file:
;; (add-to-list 'vc-handled-backends 'Pijul)
;; There are a few reasons why vc is difficult to coerce into using Pijul
;; as a backend. By default, vc expects files (not trees) to be versioned
;; as nodes in an AND/OR tree, as is done by RCS and CVS. Recent version
;; of vc allow some customisation of that, which allows smooth integration
;; with e.g. subversion.
;; Pijul doesn't version files at all; a Pijul repository is a collection
;; of patches, and a particular file version is just the set of patches
;; that have been applied in order to build it. While patches might be
;; reordered when moving between repositories, they usually remain ordered
;; (notable exceptions to that being unpull and optimize); hence,
;; a convenient mental shortcut is to identify a version by the latest
;; patch included in that version. This is what we do.
;; Internally, Pijul identifies a patch by its hash, which you may obtain
;; by using `pijul log`. We follow that approach in this code. However,
;; as a hash might be difficult to remember at times (it's 53 characters
;; long), all commands that might take an interactive argument also accept
;; a regexp identifying a patch name. See VC-PIJUL-REV-TO-HASH.
;; The fit with vc is still not quite perfect. A sore point is that vc
;; doesn't normalise versions; hence, if you have a patch called ``Initial
;; import'', you might end up with distinct but identical buffers called
;; vc-pijul.el~Init~, vc-pijul.el~Initial~ and so on.
;;; Code:
(defvar vc-pijul-version-string "0.1"
"The version string for vc-pijul.el.")
(eval-when-compile
(require 'xml)
(require 'vc))
(require 'xml)
(declare-function vc-do-async-command "vc-dispatcher"
(buffer root command &rest args))
(declare-function vc-exec-after "vc-dispatcher" (code))
(declare-function vc-setup-buffer "vc-dispatcher" (buf))
(defgroup vc-pijul nil
"*The Pijul backend for vc."
:prefix "vc-pijul-"
:group 'vc)
(defcustom vc-pijul-program-name "pijul"
"*The name of the Pijul command."
:type 'string
:group 'vc-pijul)
(defcustom vc-pijul-program-arguments '()
"*An a-list of further arguments to pass to Pijul.
Each element consists of a symbol naming the command to work on, and a
list of arguments to pass."
:type '(alist :key-type symbol :value-type (list string))
:group 'vc-pijul)
(defvar log-view-per-file-logs)
(defvar log-view-file-re)
(defvar log-view-message-re)
(defvar log-view-font-lock-keywords)
(defvar log-view-vc-fileset)
(declare-function vc-annotate-convert-time "vc-annotate" (time))
(defun vc-pijul-root (file)
"Return the root Pijul repository directory for FILE, or nil if not found."
(vc-find-root file ".pijul"))
(defalias 'vc-pijul-find-root 'vc-pijul-root)
(defun vc-pijul-special-file-p (file)
(let ((file (expand-file-name file)))
(and (string-match "/.pijul/" file)
(not (string-match "/.pijul/config" file)))))
(defun vc-pijul-do-command (command okstatus files &rest flags)
"Run Pijul COMMAND using VC-DO-COMMAND."
(let ((arguments (cdr (assq command vc-pijul-program-arguments))))
(apply #'vc-do-command "*vc*" okstatus
vc-pijul-program-name files (symbol-name command)
(append arguments flags))))
(defun vc-pijul-changes (&optional files &rest flags)
"Return a list of hashes of the patches that touch FILES in inverse order."
(with-temp-buffer
(apply #'vc-do-command t 0 vc-pijul-program-name files
"log" (append flags (cons "--hash-only" (and files (list "--")))))
(nreverse
(split-string (buffer-substring-no-properties (point-min) (point-max))))))
(defun vc-pijul-hash-p (rev)
"Return non-nil if REV has the syntax of a Pijul hash."
(and (= (length rev) 53)
(string-match "[A-Z0-9]" rev)
t))
(defun vc-pijul-rev-to-hash (rev files &optional off-by-one)
(cond
((or (null rev) (eq rev t) (equal rev "")) nil)
((not off-by-one)
(cond
((vc-pijul-hash-p rev) rev)
(t (car (last (vc-pijul-changes files "--patch" rev))))))
(t
(let ((flags
(if (vc-pijul-hash-p rev)
(list "--from-match" (concat "hash " rev))
(list "--from-patch" rev))))
(let ((changes (apply #'vc-pijul-changes files flags)))
(and (cdr changes) (car (last changes 2))))))))
(defun vc-pijul-next-revision (files rev)
"Return the revision number that follows REV for FILES."
(vc-pijul-rev-to-hash rev files t))
(defalias 'vc-pijul-next-version 'vc-pijul-next-revision)
(defun vc-pijul-previous-revision (files rev)
"Return the revision number that precedes REV for FILES."
(let ((flags
(if (vc-pijul-hash-p rev)
(list "--to-match" (concat "hash " rev))
(list "--to-patch" rev))))
(let ((changes (apply #'vc-pijul-changes files flags)))
(cadr changes))))
(defalias 'vc-pijul-previous-version 'vc-pijul-previous-revision)
(defun vc-pijul-revision-granularity () 'repository)
;;; State-querying functions
(defun vc-pijul-registered (file)
"Return non-nil if FILE is handled by Pijul."
(cond
((vc-pijul-special-file-p file)
;; If vc-directory-exclusion-list is set incorrectly, vc-dired will
;; query us for all the files under .pijul. Get rid of them quickly.
nil)
(t
(when (vc-pijul-root file)
(let* ((file (expand-file-name file))
(root (vc-pijul-root file))
(default-directory (file-name-directory file)))
(with-temp-buffer
(catch 'found
(condition-case nil
(vc-do-command t nil vc-pijul-program-name
() "list")
(error (throw 'found nil)))
(goto-char (point-min))
(while (looking-at "[^\n]+")
;; Pijul always prints relative to the root
(let* ((line (match-string 0))
(file2 (expand-file-name line root)))
(when (or
(equal file2 file)
(equal line "pijul: can't mix match and pending flags"))
(throw 'found t))
(forward-line)))
nil)))))))
(defun vc-pijul-file-times-equal-p (file1 file2)
(equal (nth 5 (file-attributes file1)) (nth 5 (file-attributes file2))))
(defun vc-pijul-parse-summary (letter)
(cond
((equal "A" letter) 'added) ; add
((equal "D" letter) 'removed) ; delete
((equal "M" letter) 'edited) ; edit
((equal "MV" letter) 'removed) ; move elsewhere
((equal "R" letter) 'edited) ; replacement
((equal "RZ" letter) 'edited) ; resurrect zombies
((equal "SC" letter) 'edited) ; solve conflict
((equal "U" letter) 'unregistered) ; untracked
((equal "UC" letter) 'conflict) ; unsolve conflict
((equal "UD" letter) 'added) ; undelete
(t 'unregistered)))
(defun vc-pijul-state (file)
"Return the state of FILE."
(with-temp-buffer
(vc-do-command t nil vc-pijul-program-name file
"diff" "--short")
(goto-char (point-min))
(cond
((looking-at "\\([A-Z]+\\) ")
(vc-pijul-parse-summary (match-string 1)))
((progn (forward-line 1) (looking-at "Error: Path not in repository: "))
nil)
(t 'up-to-date))))
(defun vc-pijul-checkout-model (_file)
"Indicate how FILE is checked out. This is always IMPLICIT with Pijul."
'implicit)
(defun vc-pijul-dir-status (dir update-function)
(let* ((dir (expand-file-name dir))
(root (vc-pijul-root dir)))
(vc-do-command t 'async vc-pijul-program-name dir "diff" "--short" "--untracted")
(vc-exec-after
`(vc-pijul-dir-status-continuation
',root ',update-function nil))))
(defun vc-pijul-dir-status-files (dir files update-function)
(let* ((dir (expand-file-name dir))
(root (vc-pijul-root dir)))
(vc-do-command t 'async vc-pijul-program-name files "diff" "--short" "--untracked")
(vc-exec-after
`(vc-pijul-dir-status-continuation
',root ',update-function ',files))))
(defun vc-pijul-dir-status-continuation (root update-function files)
(let* ((l '())
(doit #'(lambda (file status)
;; The paths printed by Pijul are relative to the root
(let ((path (file-relative-name
(expand-file-name file root))))
(unless (file-directory-p path)
(push (list path status nil) l)
(setq files (delete path files)))))))
(goto-char (point-min))
(while (not (eobp))
(cond
((looking-at "\\([A-Z]+\\) +\\([^ \n]+\\)")
(funcall doit (match-string 2)
(vc-pijul-parse-summary (match-string 1))))
((looking-at " * \\([^ \n]+\\) *-> *\\([^ \n]+\\)")
(funcall doit (match-string 1) 'removed)
(funcall doit (match-string 2) 'added)))
(forward-line))
(funcall update-function (nreverse l) (not (null files))))
(while (not (null files))
(let ((file (pop files)))
(funcall
update-function
(list (list file
(if (vc-pijul-registered file) 'up-to-date 'unregistered)
nil))
(not (null files))))))
;; Currently, there is not an easy way to tell the default remote from the other
;; remotes (other than parsing the config file), the oldest one the default, and;; order the list chronologically.
(defun vc-pijul-get-remotes (dir)
"Get the remote repository locations, if any. The default remote will
_probably_ be the first in the list."
(let ((default-directory (expand-file-name dir)))
(with-temp-buffer
(vc-do-command t 0 vc-pijul-program-name nil "remote")
(search-backward ": ")
(forward-char 2)
(kill-rectangle (point-min) (point))
(nreverse
(split-string
(buffer-substring-no-properties (point-min) (1- (point-max)))
"\n")))))
(defun vc-pijul--dir-header (width k v)
"Creates a string, stylized as a vc-dir header from a K (a string) and V
(either a string or a list of strings). K will be truncated if it is longer than
the provided width."
(concat
(propertize (concat (truncate-string-to-width k width nil ?\s t t) ": ")
'face
'vc-dir-header)
(propertize (cond ((listp v)
(mapconcat 'identity
v
(concat "\n" (make-string (+ 2 width) ?\s))))
(t
v))
'face
'vc-dir-header-value)))
(defun vc-pijul-dir-extra-headers (dir)
(let ((width 11)) ; the width of a header key in vc-dir
(mapconcat
'identity
(nconc
(let ((root (vc-pijul-root dir)))
(and root (not (equal (file-truename dir) (file-truename root)))
(list (vc-pijul--dir-header width "Repository" root))))
(let ((remotes (vc-pijul-get-remotes dir)))
(and remotes (list (vc-pijul--dir-header width "Remotes" remotes)))))
"\n")))
(defun vc-pijul-responsible-p (file)
"Return non-nil if we feel responsible for FILE,
which can also be a directory."
(when
(and (not (vc-pijul-special-file-p file))
(not (null (vc-pijul-root file))))
file))
(defun vc-pijul-could-register (file)
"Return non-nil if FILE could be registered."
(and (not (vc-pijul-special-file-p file))
(not (null (vc-pijul-root file)))))
(defun vc-pijul-working-revision (file)
"Return the working revision of FILE.
With Pijul, this is simply the hash of the last patch that touched this file."
(car (vc-pijul-changes file "--limit" "1")))
(defalias 'vc-pijul-workfile-version 'vc-pijul-working-revision)
(defun vc-pijul-workfile-unchanged-p (file)
"Return non-nil if FILE is unchanged from the repository version."
(with-temp-buffer
(vc-do-command t nil vc-pijul-program-name file
"diff" "--short")
(goto-char (point-max))
(forward-line -1)
(looking-at "No changes")))
(defun vc-pijul-mode-line-string (file)
"Return the mode line string to show for FILE."
(let ((state (vc-state file)))
(if (eq state 'up-to-date)
"pijul"
(format "pijul/%s" (vc-state file)))))
;;; State-changing functions
(defun vc-pijul-create-repo ()
(vc-pijul-do-command 'init 0 nil))
(defun vc-pijul-register (files &optional _rev _comment)
"Add FILES to the Pijul repository, and record this.
REV and COMMENT are ignored."
(vc-pijul-do-command 'add 0 files))
(defun vc-pijul-find-ignore-file (file)
(format "%s/.ignore" (vc-pijul-root file)))
(defun vc-pijul-checkin (files comment rev)
"Record FILES to Pijul. COMMENT is the new comment."
(when (not (null rev))
(error "Cannot specify check-in revision with Pijul."))
(let* ((date (format-time-string "%Y%m%d%H%M%S" nil t))
(match (string-match "\\`\\(Summary:[ \t]*\\)?\\([^\n]*\\)[ \t\n]*\\'"
comment))
(patch-name (if match
(match-string 2 comment)
comment))
(log (if match
(substring comment (match-end 0))
"")))
(vc-pijul-do-command 'record 'async files "--message" patch-name)
(with-current-buffer (get-buffer "*vc*")
(process-send-string nil (format "%s\n%s\n%s" date patch-name log))
(process-send-eof))))
(defun vc-pijul-find-revision (file rev buffer)
"Get revision REV of FILE from the Pijul repository."
(let ((rev (vc-pijul-rev-to-hash rev file)))
(apply #'vc-do-command buffer 0 vc-pijul-program-name file
"show" "contents"
(and rev (list "--match" (concat "hash " rev))))))
(defalias 'vc-pijul-find-version 'vc-pijul-find-revision)
(defun vc-pijul-checkout (file &optional _editable rev)
"Check out FILE from the Pijul repository.
EDITABLE is ignored."
(let ((rev (vc-pijul-rev-to-hash rev file)))
(when (and rev (not (equal rev (vc-pijul-workfile-version file))))
(error "Cannot checkout old revisions with Pijul."))
(or (file-exists-p file)
(vc-pijul-do-command 'reset 0 file))))
(defun vc-pijul--handle-prompt (command args)
(let* ((root (vc-pijul-root default-directory))
(buffer (format "*vc-pijul : %s*" (expand-file-name root))))
(setq args (split-string
(read-shell-command
(format "Pijul %s command: " command)
(format "%s %s %s" vc-pijul-program-name command (concat args)))
" " t))
(let ((pijul-program (car args)))
(setq command (cadr args)
args (cddr args))
(require 'vc-dispatcher)
(apply #'vc-do-async-command buffer root pijul-program command args))))
(defun vc-pijul-push (arg)
"Push the current channel."
(if arg
(vc-pijul--handle-prompt "push" nil)
(vc-pijul-do-command 'push 0 nil)))
(defun vc-pijul-pull (arg)
"Push the current channel."
(if arg
(vc-pijul--handle-prompt "pull" nil)
(vc-pijul-do-command 'pull 0 nil)))
(defun vc-pijul-revert (file &optional contents-done)
"Revert FILE back to the current workfile version."
(unless contents-done
(vc-pijul-do-command 'reset 0 file)))
;;; History functions
(define-derived-mode vc-pijul-log-view-mode log-view-mode "Pijul-Log-View"
(require 'add-log)
(set (make-local-variable 'log-view-per-file-logs) nil)
(set (make-local-variable 'log-view-file-re) "\\`a\\`")
(set (make-local-variable 'log-view-message-re)
"^patch \\([0-9a-f]\\{40\\}\\)")
(set (make-local-variable 'log-view-font-lock-keywords)
'(("^\\([A-Z][a-z][a-z] .*[0-9]\\) \\([^<>]+\\) \\(<[^<>]+>\\)"
(1 'change-log-date)
(2 'change-log-name)
(3 'change-log-email))))
)
(defun vc-pijul-show-log-entry (rev)
;; Pretty minimal, but good enough to allow C-x v l to do the right thing
(cond
((equal rev (car (vc-pijul-changes log-view-vc-fileset "--limit" "1")))
(goto-char (point-min))
(re-search-forward log-view-message-re)
(beginning-of-line))
(t
nil)))
(defun vc-pijul-print-log
(files &optional buffer _shortlog _start-revision limit)
"Print the logfile for the current Pijul repository."
;; This is a hack to make C-x v L work
(when (and (null (cdr files)) (equal (car files) (vc-pijul-root (car files))))
(setq files nil))
;; (let ((start-hash (vc-pijul-rev-to-hash start-revision files)))
(apply #'vc-do-command buffer 'async vc-pijul-program-name files "log"
(append
;; (and start-hash (list "--to-hash" start-hash))
(and limit (list "--limit" (format "%d" limit)))
(and files (list "--")))))
(defun vc-pijul-diff (file &optional rev1 rev2 buffer _async)
"Show the differences in FILE between revisions REV1 and REV2."
(let* ((rev1 (vc-pijul-rev-to-hash rev1 file t))
(rev2 (vc-pijul-rev-to-hash rev2 file))
(arguments (cdr (assq 'diff vc-pijul-program-arguments)))
(from (and rev1 (list "--from-match" (concat "hash " rev1))))
(to (and rev2 (list "--to-match" (concat "hash " rev2)))))
(apply #'vc-do-command (or buffer "*vc-diff*")
nil ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=21969
vc-pijul-program-name file
"diff"
(append from to arguments))))
(defun vc-pijul-rename-file (old new)
"Rename the file OLD to NEW in the pijul repository."
(vc-pijul-do-command 'move 0 nil old new))
(defun vc-pijul-delete-file (file)
(delete-file file))
(defun vc-pijul-parse-integer (string)
(let* ((c (read-from-string string))
(n (car c)))
(if (integerp n) n 0)))
(defun vc-pijul-alist-from-rev (_file rev)
(let ((alist ()))
(with-temp-buffer
(vc-do-command t 0 vc-pijul-program-name '() "change" rev)
(goto-char (point-min))
(while (progn
(if (looking-at "\\(.*\\) = '\\(.*\\)'")
(let ((key (pcase (match-string 1)
("message" 'message)
("timestamp" 'date)
("name" 'author))))
(when key
(push (cons key (match-string 2)) alist))))
(= 0 (forward-line))))
alist)))
(defun vc-pijul-annotate-command (file buffer &optional rev)
"Produce an annotated display of fiLE in BUFFER.
For Pijul, hashes and times are stored in text properties."
(vc-setup-buffer buffer)
(let* ((_rev (vc-pijul-rev-to-hash rev file))
(data
(with-temp-buffer
(apply #'vc-do-command t 0 vc-pijul-program-name file "credit" nil)
(let ((current-hash nil)
(output ()))
(goto-char (point-min))
(while (progn
(cond ((looking-at "^\\([A-Z0-9]+\\)\\(?:, [A-Z0-9]+\\)*$")
(message (match-string 1))
(setq current-hash (match-string 1)))
((looking-at "^> \\(.*\\)$")
(message (match-string 1))
(push (cons current-hash (match-string 1)) output)))
(= 0 (forward-line 1))))
(nreverse output)))))
(with-current-buffer buffer
(let ((reporter
(and (fboundp 'make-progress-reporter)
(make-progress-reporter "Annotating..."
1 (length data))))
(count 0)
(now (vc-annotate-convert-time (current-time)))
(cache '()))
(dolist (e data)
(let* ((rev (car e))
(line (cdr e))
(alist (or (cdr (assoc rev cache))
(let ((a (vc-pijul-alist-from-rev file rev)))
(push (cons rev a) cache)
a)))
(author (cdr (assoc 'author alist)))
(date (cdr (assoc 'date alist)))
(year (substring date 0 4))
(month (substring date 5 7))
(day (substring date 8 10))
(hour (substring date 11 13))
(min (substring date 14 16))
(sec (substring date 17 19))
(time (vc-annotate-convert-time
(encode-time
(vc-pijul-parse-integer sec)
(vc-pijul-parse-integer min)
(vc-pijul-parse-integer hour)
(vc-pijul-parse-integer day)
(vc-pijul-parse-integer month)
(vc-pijul-parse-integer year))))
(begin (point))
)
(insert (format "%-12s " rev))
(cond
((string-match "<\\([^ <>@]*\\)@.*>" author)
(setq author (match-string 1 author)))
((string-match "[^ <>@]*" author)
(setq author (match-string 0 author))))
(insert (format "%-7s "
(if (> (length author) 7)
(substring author 0 7)
author)))
(insert
(if (> (- now time) 0.9)
(format "%s-%s-%s " year month day)
(format "%s:%s:%s " hour min sec)))
(insert line)
(insert "\n")
(add-text-properties
begin (point)
(list 'vc-pijul-annotate (cons rev time))))
(setq count (+ count 1))
(when reporter
(progress-reporter-update reporter count)))
(when reporter
(progress-reporter-done reporter))))))
(defun vc-pijul-annotate-extract-revision-at-line ()
(car (get-text-property (point) 'vc-pijul-annotate (current-buffer))))
(defun vc-pijul-annotate-time ()
(cdr (get-text-property (point) 'vc-pijul-annotate (current-buffer))))
(provide 'vc-pijul)
;;; vc-pijul.el ends here