changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/vc/git.lisp

changeset 389: 95b861dff3d8
parent: dec30b6fd500
child: 0f0e5f9b5c55
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 31 May 2024 23:28:35 -0400
permissions: -rw-r--r--
description: box,skel,vc,obj upgrades, moved XDB to demo/examples/db 
     1 (in-package :vc/git)
     2 
     3 (deferror git-error (vc-error) () (:auto t))
     4 
     5 (defvar *git-program* (cli:find-exe "git"))
     6 
     7 (defun run-git-command (cmd &optional args output (wait t))
     8   (unless (listp args) (setf args (list args)))
     9   (setf args (mapcar #'vc/proto::namestring-or args)) ;;  TODO 2024-05-10: slow
    10   (sb-ext:run-program *git-program* (push cmd args) :output output :wait wait :input nil))
    11 
    12 (defun git-url-p (url)
    13   "Return nil if URL does not look like a URL to a git valid remote."
    14   (let ((url-str (if (typep url 'pathname)
    15                      (namestring url)
    16                      url)))
    17     (ppcre:scan '(:alternation
    18             (:regex "\\.git$")
    19             (:regex "^git://")
    20             (:regex "^https://git\\.")
    21             (:regex "^git@"))
    22           url-str)))
    23 
    24 (defun gitignore (&optional (path ".gitignore"))
    25   (vc/proto::make-vc-ignore :path path :patterns (vc/proto::map-lines #'vc/proto::glob-path-match path)))
    26 
    27 (defclass git-repo (vc-repo)
    28   ((index))) ;; working-directory
    29 
    30 (defmethod vc-init ((self (eql :git)))
    31   (make-instance 'git-repo :path (pathname *default-pathname-defaults*)))
    32 
    33 (defmethod vc-init ((self git-repo))
    34   (with-slots (path) self
    35     (let ((existed (probe-file path)))
    36       (if (zerop (sb-ext:process-exit-code (run-git-command "init" path)))
    37           (not existed)
    38           (git-error "git init failed:" path)))))
    39 
    40 (defmethod vc-run ((self git-repo) (cmd string) &rest args)
    41   (with-slots (path) self
    42     (uiop:with-current-directory (path)
    43       (with-open-stream (s (sb-ext:process-output (apply #'run-git-command cmd args)))
    44         (with-output-to-string (str)
    45           (loop for l = (read-line s nil nil)
    46                 while l
    47                 do (write-line l)))))))
    48 
    49 (defmethod vc-init ((self git-repo))
    50   (with-slots (path) self
    51     ;; could throw error here but w/e
    52     (sb-ext:process-exit-code (run-git-command "init" path))))
    53 
    54 (defmethod vc-clone ((self git-repo) remote &key &allow-other-keys)
    55   (with-slots (path) self
    56     (sb-ext:process-exit-code (run-git-command "clone" remote path))))
    57 
    58 (defmethod vc-pull ((self git-repo) remote &key &allow-other-keys)
    59   (with-slots (path) self
    60     (uiop:with-current-directory (path)
    61       (sb-ext:process-exit-code (run-git-command "pull" remote)))))
    62 
    63 (defmethod vc-push ((self git-repo) remote &key &allow-other-keys)
    64   (with-slots (path) self
    65     (uiop:with-current-directory (path)
    66       (sb-ext:process-exit-code (run-git-command "push" remote)))))
    67 
    68 (defmethod vc-commit ((self git-repo) msg &key &allow-other-keys)
    69   (with-slots (path) self
    70     (uiop:with-current-directory (path)
    71       (sb-ext:process-exit-code (run-git-command "commit" "-m" msg)))))
    72 
    73 (defmethod vc-add ((self git-repo) &rest files)
    74   (with-slots (path) self
    75     (uiop:with-current-directory (path)
    76       (sb-ext:process-exit-code (apply #'run-git-command "add" files)))))
    77 
    78 (defmethod vc-remove ((self git-repo) &rest files)
    79   (with-slots (path) self
    80     (uiop:with-current-directory (path)
    81       (sb-ext:process-exit-code (apply #'run-git-command "remove" files)))))
    82 
    83 ;; TODO
    84 (defmethod vc-addremove ((self git-repo) &rest files)
    85   (with-slots (path) self
    86     (uiop:with-current-directory (path)
    87       (sb-ext:process-exit-code (apply #'run-git-command "addremove" files)))))
    88 
    89 (defmethod vc-status ((self git-repo) &key &allow-other-keys) (vc-run self "status"))
    90 
    91 (defmethod vc-branch ((self git-repo)) (vc-run self "branch"))
    92 
    93 (defmethod vc-diff ((a git-repo) (b git-repo) &key &allow-other-keys)
    94   (vc-run a "diff" (vc/proto::vc-repo-head a) (vc/proto::vc-repo-head b)))
    95 
    96 (defmethod vc-id ((self git-repo))
    97   (with-slots (path) self
    98     (uiop:with-current-directory (path)
    99       (with-open-stream (s (sb-ext:process-output (run-git-command "id")))
   100         (with-output-to-string (str)
   101           (loop for c = (read-char s nil nil)
   102                 while c
   103                 do (write-char c str))
   104           str)))))
   105 
   106 ;; TODO 2023-12-29: does git have a cmdserver?
   107 ;; (declaim (inline make-git-client))
   108 ;; (defstruct git-client
   109 ;;   (pid 0 :type fixnum :read-only t)
   110 ;;   (pgid 0 :type fixnum)
   111 ;;   (cwd (sb-posix:getcwd) :type string))