changelog shortlog graph tags branches changeset files revisions annotate raw help

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

changeset 698: 96958d3eb5b0
parent: 35a579313b80
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     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 ;; https://git-scm.com/docs/git-config
    28 (defclass git-config (vc-config) ())
    29 
    30 ;; TODO 2024-08-22: read ini files
    31 (defmethod find-cfg ((obj (eql :git)) &rest args &key (directory (user-homedir-pathname)))
    32   (declare (ignore args))
    33   (let ((*default-pathname-defaults* directory))
    34     (when-let ((cfg (directory ".gitconfig")))
    35       (car cfg))))
    36 
    37 (defclass git-repo (vc-repo)
    38   ((index))) ;; working-directory
    39 
    40 (defmethod vc-init ((self (eql :git)))
    41   (make-instance 'git-repo :path (pathname *default-pathname-defaults*)))
    42 
    43 (defmethod vc-init ((self git-repo))
    44   (let ((path (vc-path self)))
    45     (if (zerop (sb-ext:process-exit-code (run-git-command "init" path)))
    46         (not (probe-file path))
    47         (git-error "git init failed:" path))))
    48 
    49 (defmethod vc-run ((self git-repo) (cmd string) &rest args)
    50   (uiop:with-current-directory ((vc-path self))
    51     (with-open-stream (s (sb-ext:process-output (apply #'run-git-command cmd args)))
    52       (with-output-to-string (str)
    53         (loop for l = (read-line s nil nil)
    54               while l
    55               do (write-line l))))))
    56 
    57 (defmethod vc-clone ((self git-repo) remote &key &allow-other-keys)
    58   (with-slots (path) self
    59     (sb-ext:process-exit-code (run-git-command "clone" remote path))))
    60 
    61 (defmethod vc-pull ((self git-repo) &optional (remote "main"))
    62   (with-slots (path) self
    63     (uiop:with-current-directory (path)
    64       (sb-ext:process-exit-code (run-git-command "pull" remote)))))
    65 
    66 (defmethod vc-push ((self git-repo) &optional (remote "main"))
    67   (with-slots (path) self
    68     (uiop:with-current-directory (path)
    69       (sb-ext:process-exit-code (run-git-command "push" remote)))))
    70 
    71 (defmethod vc-commit ((self git-repo) msg &key &allow-other-keys)
    72   (with-slots (path) self
    73     (uiop:with-current-directory (path)
    74       (sb-ext:process-exit-code (run-git-command "commit" "-m" msg)))))
    75 
    76 (defmethod vc-add ((self git-repo) &rest files)
    77   (with-slots (path) self
    78     (uiop:with-current-directory (path)
    79       (sb-ext:process-exit-code (apply #'run-git-command "add" files)))))
    80 
    81 (defmethod vc-remove ((self git-repo) &rest files)
    82   (with-slots (path) self
    83     (uiop:with-current-directory (path)
    84       (sb-ext:process-exit-code (apply #'run-git-command "remove" files)))))
    85 
    86 ;; TODO
    87 (defmethod vc-addremove ((self git-repo) &rest files)
    88   (with-slots (path) self
    89     (uiop:with-current-directory (path)
    90       (sb-ext:process-exit-code (apply #'run-git-command "addremove" files)))))
    91 
    92 (defmethod vc-status ((self git-repo) &key &allow-other-keys) (vc-run self "status"))
    93 
    94 (defmethod vc-branch ((self git-repo)) (vc-run self "branch"))
    95 
    96 (defmethod vc-diff ((a git-repo) (b git-repo) &key &allow-other-keys)
    97   (vc-run a "diff" (vc-head a) (vc-head b)))
    98 
    99 (defmethod vc-id ((self git-repo))
   100   (with-slots (path) self
   101     (uiop:with-current-directory (path)
   102       (with-open-stream (s (sb-ext:process-output (run-git-command "id")))
   103         (with-output-to-string (str)
   104           (loop for c = (read-char s nil nil)
   105                 while c
   106                 do (write-char c str))
   107           str)))))
   108 
   109 ;; TODO 2023-12-29: does git have a cmdserver?
   110 ;; (declaim (inline make-git-client))
   111 ;; (defstruct git-client
   112 ;;   (pid 0 :type fixnum :read-only t)
   113 ;;   (pgid 0 :type fixnum)
   114 ;;   (cwd (sb-posix:getcwd) :type string))