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 README.org for more information. See
;;;; LICENSE for license information.
(uiop:define-package #:clpm/cli/hack
(:use #:cl
#:clpm/cli/common-args
#:clpm/cli/subcommands
#:clpm/log
#:clpm/repos
#:clpm/source)
(:import-from #:adopt))
(in-package #:clpm/cli/hack)
(setup-logger)
(adopt:define-string *help-text*
"Given a system or project name, clone its repository to start hacking on it.")
(defparameter *option-hack-source*
(adopt:make-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*
(adopt:make-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*
(adopt:make-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*
(adopt:make-interface
:name "clpm hack"
:summary "Common Lisp Package Manager Hack"
:usage "hack [options] SYSTEM-OR-PROJECT"
:help *help-text*
:contents (list *group-common*
*option-hack-source*
*option-hack-project*
*option-hack-local*)))
(defun find-project-source (project-name sources)
(loop
:for source :in sources
:when (source-project source project-name nil)
:do (return source)))
(defun find-system-source (system-name sources)
(loop
: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))
(dir-pathname)
(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)))
project)
(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))
t))
......@@ -11,6 +11,7 @@
#:clpm/cli/config
#:clpm/cli/context
#:clpm/cli/entry
#:clpm/cli/hack
#:clpm/cli/install
#:clpm/cli/license-info
#:clpm/cli/sync
......
......@@ -7,6 +7,7 @@
(uiop:define-package #:clpm/repos/defs
(:use #:cl)
(:export #:*fetch-repo-automatically*
#:clone-repo!
#:ensure-ref-present-locally!
#:ref-present-p
#:repo-archive-stream
......@@ -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~."
(apply
#'uiop:run-program
`(,@prefix "clone"
"--bare"
,@(unless not-bare-p
'("--bare" "--mirror"))
"--verbose"
"--mirror"
,uri-string
,(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