Commit a4c646e8 authored by Eric Timmons's avatar Eric Timmons
Browse files

Add a hack command to clone a project's repo

parent b070a681
;;;; clpm hack
;;;; This software is part of CLPM. See for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm/cli/hack
(:use #:cl
(:import-from #:adopt))
(in-package #:clpm/cli/hack)
(adopt:define-string *help-text*
"Given a system or project name, clone its repository to start hacking on it.")
(defparameter *option-hack-source*
:long "source"
:parameter "SOURCE-NAME"
:help "The name of the source to get repo data from"
:reduce #'adopt:last))
(defparameter *option-hack-project*
:short #\p
:help "If provided, the argument is assumed to be a project name instead of a system name"
:reduce (constantly t)))
(defparameter *option-hack-local*
:long "local"
:help "If provided, the repo will be cloned from CLPM's cached version of the repo"
:reduce (constantly t)))
(defparameter *hack-ui*
:name "clpm hack"
:summary "Common Lisp Package Manager Hack"
:usage "hack [options] SYSTEM-OR-PROJECT"
:help *help-text*
:contents (list *group-common*
(defun find-project-source (project-name sources)
:for source :in sources
:when (source-project source project-name nil)
:do (return source)))
(defun find-system-source (system-name sources)
:for source :in sources
:when (source-system source system-name nil)
:do (return source)))
(define-cli-command (("hack") *hack-ui*) (args options)
(let* ((name (first args))
(dir-name (second args))
(source-name (gethash :hack-source options))
(hack-project-p (gethash :hack-project options))
(sources (sources))
(source (when source-name (find source-name sources :test #'equal :key #'source-name)))
(unless name
(error "A project or system name is required"))
(if hack-project-p
(setf source (find-project-source name sources))
(setf source (find-system-source name sources)))
(unless source
(error "unable to find a source to provide the repo!"))
(if hack-project-p
(setf project (source-project source name))
;; TODO: Need to add something like system-projects.
(setf project (release-project (first (system-releases (source-system source name))))))
(unless dir-name
(setf dir-name (project-name project)))
(setf dir-pathname (uiop:ensure-directory-pathname (merge-pathnames dir-name)))
(when (probe-file dir-pathname)
(error "Directory already exists. Aborting."))
(let ((repo (project-repo project)))
(clone-repo! repo :pathname dir-pathname :not-bare-p t))
......@@ -11,6 +11,7 @@
......@@ -7,6 +7,7 @@
(uiop:define-package #:clpm/repos/defs
(:use #:cl)
(:export #:*fetch-repo-automatically*
......@@ -20,6 +21,8 @@
(defvar *fetch-repo-automatically* t)
(defgeneric clone-repo! (repo &key pathname not-bare-p))
(defgeneric ensure-ref-present-locally! (repo ref))
(defgeneric ref-present-p (repo ref))
......@@ -179,9 +179,10 @@ optionally changing into the local dir for ~repo~."
exit-code output error-output)
(error 'retriable-error)))))))
(defun clone-repo! (repo)
(defmethod clone-repo! ((repo git-repo) &key pathname not-bare-p)
"Given a repo, clone it locally."
(let* ((local-dir (git-repo-local-dir repo))
(let* ((local-dir (or (when pathname (uiop:ensure-directory-pathname pathname))
(git-repo-local-dir repo)))
(uri-string (git-repo-uri-string repo))
(credentials (git-repo-credentials repo)))
(multiple-value-bind (prefix env)
......@@ -190,9 +191,9 @@ optionally changing into the local dir for ~repo~."
`(,@prefix "clone"
,@(unless not-bare-p
'("--bare" "--mirror"))
,(namestring local-dir))
:input :interactive
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment