From: Aleksandr Vityazev via "Bug reports for GNU Emacs, the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>
To: Philip Kaludercic <philipk@posteo.net>
Cc: Eli Zaretskii <eliz@gnu.org>, 73357@debbugs.gnu.org
Subject: bug#73357: [PATCH] Make vc-clone interactive
Date: Sun, 06 Oct 2024 17:50:54 +0300 [thread overview]
Message-ID: <87y131ffox.fsf@disroot.org> (raw)
In-Reply-To: <87jzesulk7.fsf@posteo.net> (Philip Kaludercic's message of "Tue, 01 Oct 2024 11:09:12 +0000")
[-- Attachment #1: Type: text/plain, Size: 17979 bytes --]
On 2024-10-01 11:09, Philip Kaludercic wrote:
> Aleksandr Vityazev <avityazev@disroot.org> writes:
>
>
> [...]
>
>>>> + (if backend
>>>> + (progn
>>>> + (unless (memq backend vc-handled-backends)
>>>> + (error "Unknown VC backend %s" backend))
>>>> + (vc-call-backend backend 'clone remote directory rev))
>>>> + (catch 'ok
>>>> + (dolist (backend vc-handled-backends)
>>>> + (ignore-error vc-not-supported
>>>> + (when-let ((res (vc-call-backend
>>>> + backend 'clone
>>>> + remote directory rev)))
>>>> + (throw 'ok res)))))))
>>>> + (when (file-directory-p directory)
>>>> + (if (called-interactively-p 'interactive)
>>>
>>> Perhaps we can add a FIND-FILE argument to the end, so that it is also
>>> possible to open the directory from a script as well.
>>
>> might be useful, added and documented in doc string.
>>
>>>
>>>> + (find-file directory)
>>>> + directory))))
>>>
>>> I'd always return `directory', that seems simpler.
>>
>> Simpler, but it seems logical to switch to a directory when using it
>> interactively. I left it as it was.
>
> What I meant was to write
>
> (defun vc-clone (... &optional ... open-dir)
> (interactive (list ... t))
> ...
> (when open-dir
> (dired directory))
> directory)
>
> instead of
>
> (defun vc-clone (... &optional ... open-dir)
> (interactive (list ... t))
> ...
> (if open-dir
> (dired directory)
> directory))
>
> The advantage is that you can still request the directory to be opened
> when invoked non-interactively, you avoid the ambiguity of
> `called-interactively-p' and the return value is always of the same
> type, and not sometimes whatever `find-file'/`dired' returns.
>
>>>
>>>>
>>>> (declare-function log-view-current-tag "log-view" (&optional pos))
>>>> (defun vc-default-last-change (_backend file line)
>>>> --
>>>> 2.46.0
>>
>> V3 patch:
>>
>> From 6d5dbb1d1354d7476caaeeecfe15b8fd6335490a Mon Sep 17 00:00:00 2001
>> Message-ID: <6d5dbb1d1354d7476caaeeecfe15b8fd6335490a.1727634026.git.avityazev@disroot.org>
>> From: Aleksandr Vityazev <avityazev@disroot.org>
>> Date: Sun, 29 Sep 2024 21:13:28 +0300
>> Subject: [PATCH] Make vc-clone interactive
>>
>> * lisp/vc/vc.el (vc-clone): Make interactive. Add optional
>> argument FIND-FILE. Mention these changes in the doc string.
>> (vc--remotes-history): New defvar.
>> * lisp/emacs-lisp/package-vc (package-vc--backend-type,
>> package-vc-heuristic-alist, package-vc--guess-backend):
>> Rename and move to ...
>> (package-vc-default-backend): Set type to vc-backend-type.
>> (package-vc--clone, package-vc--read-package-name, package-vc-install,
>> package-vc-checkout): Use vc-guess-backend.
>> * lisp/vc/vc (vc-backend-type, vc-heuristic-alist, vc-guess-backend):
>> ... here.
>> * etc/NEWS: Announce these changes.
>
> I think it would cleaner if we split this up into two commits:
>
> 1. Moving `package-vc-heuristic-alist',
> 2. Making `vc-clone' interactive.
>
done
>> ---
>> etc/NEWS | 12 ++++
>> lisp/emacs-lisp/package-vc.el | 75 ++--------------------
>> lisp/vc/vc.el | 115 +++++++++++++++++++++++++++++-----
>> 3 files changed, 118 insertions(+), 84 deletions(-)
>>
>> diff --git a/etc/NEWS b/etc/NEWS
>> index aaf3783f006..3722e12c01d 100644
>> --- a/etc/NEWS
>> +++ b/etc/NEWS
>> @@ -444,6 +444,18 @@ toggle.
>> Putting (require 'midnight) in your init file no longer activates the
>> mode. Now, one needs to say (midnight-mode +1) instead.
>>
>> +** VC
>> +
>> +*** 'vc-clone' is now an interactive command.
>> +When called interactively, 'vc-clone' now prompts for the remote
>> +repository address, the backend for cloning, if it has not been
>> +determined automatically according to the URL, and the directory to
>> +clone the repository into.
>> +
>> +*** 'vc-clone' now accepts an optional argument FIND-FILE.
>> +When the argument is non-nil, the function switches to a buffer visiting
>> +directory to which the repository was cloned.
>> +
>> \f
>> * New Modes and Packages in Emacs 31.1
>>
>> diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el
>> index e168096e153..82b450368d0 100644
>> --- a/lisp/emacs-lisp/package-vc.el
>> +++ b/lisp/emacs-lisp/package-vc.el
>> @@ -63,62 +63,6 @@ package-vc
>> (defconst package-vc--elpa-packages-version 1
>> "Version number of the package specification format understood by package-vc.")
>>
>> -(defconst package-vc--backend-type
>> - `(choice :convert-widget
>> - ,(lambda (widget)
>> - (let (opts)
>> - (dolist (be vc-handled-backends)
>> - (when (or (vc-find-backend-function be 'clone)
>> - (alist-get 'clone (get be 'vc-functions)))
>> - (push (widget-convert (list 'const be)) opts)))
>> - (widget-put widget :args opts))
>> - widget))
>> - "The type of VC backends that support cloning package VCS repositories.")
>> -
>> -(defcustom package-vc-heuristic-alist
>> - `((,(rx bos "http" (? "s") "://"
>> - (or (: (? "www.") "github.com"
>> - "/" (+ (or alnum "-" "." "_"))
>> - "/" (+ (or alnum "-" "." "_")))
>> - (: "codeberg.org"
>> - "/" (+ (or alnum "-" "." "_"))
>> - "/" (+ (or alnum "-" "." "_")))
>> - (: (? "www.") "gitlab" (+ "." (+ alnum))
>> - "/" (+ (or alnum "-" "." "_"))
>> - "/" (+ (or alnum "-" "." "_")))
>> - (: "git.sr.ht"
>> - "/~" (+ (or alnum "-" "." "_"))
>> - "/" (+ (or alnum "-" "." "_")))
>> - (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/"
>> - (or "r" "git") "/"
>> - (+ (or alnum "-" "." "_")) (? "/")))
>> - (or (? "/") ".git") eos)
>> - . Git)
>> - (,(rx bos "http" (? "s") "://"
>> - (or (: "hg.sr.ht"
>> - "/~" (+ (or alnum "-" "." "_"))
>> - "/" (+ (or alnum "-" "." "_")))
>> - (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/"
>> - (+ (or alnum "-" "." "_")) (? "/")))
>> - eos)
>> - . Hg)
>> - (,(rx bos "http" (? "s") "://"
>> - (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/"
>> - (+ (or alnum "-" "." "_")) (? "/")))
>> - eos)
>> - . Bzr))
>> - "Alist mapping repository URLs to VC backends.
>> -`package-vc-install' consults this alist to determine the VC
>> -backend from the repository URL when you call it without
>> -specifying a backend. Each element of the alist has the form
>> -\(URL-REGEXP . BACKEND). `package-vc-install' will use BACKEND of
>> -the first association for which the URL of the repository matches
>> -the URL-REGEXP of the association. If no match is found,
>> -`package-vc-install' uses `package-vc-default-backend' instead."
>> - :type `(alist :key-type (regexp :tag "Regular expression matching URLs")
>> - :value-type ,package-vc--backend-type)
>> - :version "29.1")
>> -
>
> This should certainly be replaced by a
> `define-obsolete-variable-alias'!
Fixed
>
>> (defcustom package-vc-default-backend 'Git
>> "Default VC backend to use for cloning package repositories.
>> `package-vc-install' uses this backend when you specify neither
>> @@ -127,7 +71,7 @@ package-vc-default-backend
>>
>> The value must be a member of `vc-handled-backends' that supports
>> the `clone' VC function."
>> - :type package-vc--backend-type
>> + :type vc-backend-type
>> :version "29.1")
>>
>> (defcustom package-vc-register-as-project t
>> @@ -626,13 +570,6 @@ package-vc--unpack-1
>> "")))
>> t))
>>
>> -(defun package-vc--guess-backend (url)
>> - "Guess the VC backend for URL.
>> -This function will internally query `package-vc-heuristic-alist'
>> -and return nil if it cannot reasonably guess."
>> - (and url (alist-get url package-vc-heuristic-alist
>> - nil nil #'string-match-p)))
>> -
>> (declare-function project-remember-projects-under "project" (dir &optional recursive))
>>
>> (defun package-vc--clone (pkg-desc pkg-spec dir rev)
>> @@ -646,7 +583,7 @@ package-vc--clone
>> (unless (file-exists-p dir)
>> (make-directory (file-name-directory dir) t)
>> (let ((backend (or (plist-get pkg-spec :vc-backend)
>> - (package-vc--guess-backend url)
>> + (vc-guess-backend url)
>> (plist-get (alist-get (package-desc-archive pkg-desc)
>> package-vc--archive-data-alist
>> nil nil #'string=)
>> @@ -753,7 +690,7 @@ package-vc--read-package-name
>> ;; pointing towards a repository, and use that as a backup
>> (and-let* ((extras (package-desc-extras (cadr pkg)))
>> (url (alist-get :url extras))
>> - ((package-vc--guess-backend url)))))))
>> + ((vc-guess-backend url)))))))
>> (not allow-url)))
>>
>> (defun package-vc--read-package-desc (prompt &optional installed)
>> @@ -917,7 +854,7 @@ package-vc-install
>> (cdr package)
>> rev))
>> ((and-let* (((stringp package))
>> - (backend (or backend (package-vc--guess-backend package))))
>> + (backend (or backend (vc-guess-backend package))))
>> (package-vc--unpack
>> (package-desc-create
>> :name (or name (intern (file-name-base package)))
>> @@ -930,7 +867,7 @@ package-vc-install
>> (or (package-vc--desc->spec (cadr desc))
>> (and-let* ((extras (package-desc-extras (cadr desc)))
>> (url (alist-get :url extras))
>> - (backend (package-vc--guess-backend url)))
>> + (backend (vc-guess-backend url)))
>> (list :vc-backend backend :url url))
>> (user-error "Package `%s' has no VC data" package))
>> rev)))
>> @@ -958,7 +895,7 @@ package-vc-checkout
>> (let ((pkg-spec (or (package-vc--desc->spec pkg-desc)
>> (and-let* ((extras (package-desc-extras pkg-desc))
>> (url (alist-get :url extras))
>> - (backend (package-vc--guess-backend url)))
>> + (backend (vc-guess-backend url)))
>> (list :vc-backend backend :url url))
>> (user-error "Package `%s' has no VC data"
>> (package-desc-name pkg-desc)))))
>> diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
>> index 597a1622f5a..cd877bd8097 100644
>> --- a/lisp/vc/vc.el
>> +++ b/lisp/vc/vc.el
>> @@ -929,7 +929,69 @@ vc-find-revision-no-save
>> :type 'boolean
>> :version "27.1")
>>
>> +(defconst vc-backend-type
>> + `(choice :convert-widget
>> + ,(lambda (widget)
>> + (let (opts)
>> + (dolist (be vc-handled-backends)
>> + (when (or (vc-find-backend-function be 'clone)
>> + (alist-get 'clone (get be 'vc-functions)))
>> + (push (widget-convert (list 'const be)) opts)))
>> + (widget-put widget :args opts))
>> + widget))
>> + "The type of VC backends that support cloning VCS repositories.")
>> +
>> +(defcustom vc-heuristic-alist
>> + `((,(rx bos "http" (? "s") "://"
>> + (or (: (? "www.") "github.com"
>> + "/" (+ (or alnum "-" "." "_"))
>> + "/" (+ (or alnum "-" "." "_")))
>> + (: "codeberg.org"
>> + "/" (+ (or alnum "-" "." "_"))
>> + "/" (+ (or alnum "-" "." "_")))
>> + (: (? "www.") "gitlab" (+ "." (+ alnum))
>> + "/" (+ (or alnum "-" "." "_"))
>> + "/" (+ (or alnum "-" "." "_")))
>> + (: "git.sr.ht"
>> + "/~" (+ (or alnum "-" "." "_"))
>> + "/" (+ (or alnum "-" "." "_")))
>> + (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/"
>> + (or "r" "git") "/"
>> + (+ (or alnum "-" "." "_")) (? "/")))
>> + (or (? "/") ".git") eos)
>> + . Git)
>> + (,(rx bos "http" (? "s") "://"
>> + (or (: "hg.sr.ht"
>> + "/~" (+ (or alnum "-" "." "_"))
>> + "/" (+ (or alnum "-" "." "_")))
>> + (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/"
>> + (+ (or alnum "-" "." "_")) (? "/")))
>> + eos)
>> + . Hg)
>> + (,(rx bos "http" (? "s") "://"
>> + (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/"
>> + (+ (or alnum "-" "." "_")) (? "/")))
>> + eos)
>> + . Bzr))
>> + "Alist mapping repository URLs to VC backends.
>> +`vc-clone' consults this alist to determine the VC
>> +backend from the repository URL when you call it without
>> +specifying a backend. Each element of the alist has the form
>> +\(URL-REGEXP . BACKEND). `vc-clone' will use BACKEND of
>> +the first association for which the URL of the repository matches
>> +the URL-REGEXP of the association."
>> + :type `(alist :key-type (regexp :tag "Regular expression matching URLs")
>> + :value-type ,vc-backend-type)
>> + :version "29.1")
>> +
>> \f
>> +(defun vc-guess-backend (url)
>> + "Guess the VC backend for URL.
>> +This function will internally query `vc-heuristic-alist'
>> +and return nil if it cannot reasonably guess."
>> + (and url (alist-get url vc-heuristic-alist
>> + nil nil #'string-match-p)))
>> +
>> ;; File property caching
>>
>> (defun vc-clear-context ()
>> @@ -3804,7 +3866,9 @@ vc-check-headers
>> (interactive)
>> (vc-call-backend (vc-backend buffer-file-name) 'check-headers))
>>
>> -(defun vc-clone (remote &optional backend directory rev)
>> +(defvar vc--remotes-history)
>> +
>> +(defun vc-clone (remote &optional backend directory rev find-file)
>> "Clone repository REMOTE using version-control BACKEND, into DIRECTORY.
>> If successful, return the string with the directory of the checkout;
>> otherwise return nil.
>> @@ -3814,20 +3878,41 @@ vc-clone
>> If BACKEND is nil or omitted, the function iterates through every known
>> backend in `vc-handled-backends' until one succeeds to clone REMOTE.
>> If REV is non-nil, it indicates a specific revision to check out after
>> -cloning; the syntax of REV depends on what BACKEND accepts."
>> - (setq directory (expand-file-name (or directory default-directory)))
>> - (if backend
>> - (progn
>> - (unless (memq backend vc-handled-backends)
>> - (error "Unknown VC backend %s" backend))
>> - (vc-call-backend backend 'clone remote directory rev))
>> - (catch 'ok
>> - (dolist (backend vc-handled-backends)
>> - (ignore-error vc-not-supported
>> - (when-let ((res (vc-call-backend
>> - backend 'clone
>> - remote directory rev)))
>> - (throw 'ok res)))))))
>> +cloning; the syntax of REV depends on what BACKEND accepts.
>> +If FIND-FILE is non-nil, switches to a buffer visiting DIRECTORY to
>> +which the repository was cloned. It would be useful in scripts, but not
>> +in regular code.
>> +If called interactively, prompt for REMOTE, DIRECTORY and BACKEND,
>> +if BACKEND has not been automatically determined according to the REMOTE
>> +URL, in the minibuffer."
>> + (interactive
>> + (let* ((url (read-string "Remote: " nil 'vc--remotes-history))
>> + (backend (or (vc-guess-backend url)
>> + (intern (completing-read
>> + "Backend: " vc-handled-backends nil t)))))
>> + (list url backend
>> + (read-directory-name
>> + "Clone into new or empty directory: " nil nil
>> + (lambda (dir) (or (not (file-exists-p dir))
>> + (directory-empty-p dir)))))))
>> + (let* ((directory (expand-file-name (or directory default-directory)))
>> + (backend (or backend (vc-guess-backend remote)))
>> + (directory (if backend
>> + (progn
>> + (unless (memq backend vc-handled-backends)
>> + (error "Unknown VC backend %s" backend))
>> + (vc-call-backend backend 'clone remote directory rev))
>> + (catch 'ok
>> + (dolist (backend vc-handled-backends)
>> + (ignore-error vc-not-supported
>> + (when-let ((res (vc-call-backend
>> + backend 'clone
>> + remote directory rev)))
>> + (throw 'ok res))))))))
>> + (when (file-directory-p directory)
>
> When is this not true?
When calling interactively, we can choose a path to a directory that
does not exist, then if the clone operation fails, a path that is not a
directory will be returned. If the cloning operation succeeds, it will
be true. This also applies if the directory already exists.
>
>> + (if (or find-file (called-interactively-p 'interactive))
>> + (find-file directory)
>> + directory))))
>>
>> (declare-function log-view-current-tag "log-view" (&optional pos))
>> (defun vc-default-last-change (_backend file line)
>> --
>> 2.46.0
V4 patches:
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: [PATCH] Move package-vc-heuristic-alist and related to vc.el --]
[-- Type: text/x-patch, Size: 10148 bytes --]
From 0f2d2f91ca9ecfdf42e891a462ce4aa75e77a0ad Mon Sep 17 00:00:00 2001
Message-ID: <0f2d2f91ca9ecfdf42e891a462ce4aa75e77a0ad.1728225805.git.avityazev@disroot.org>
From: Aleksandr Vityazev <avityazev@disroot.org>
Date: Sun, 6 Oct 2024 17:30:10 +0300
Subject: [PATCH] Move package-vc-heuristic-alist and related to vc.el
* lisp/emacs-lisp/package-vc (package-vc--backend-type,
package-vc-heuristic-alist, package-vc--guess-backend):
Rename and move to ...
(package-vc-heuristic-alist): Make obsolete.
(package-vc-default-backend): Set type to vc-backend-type.
(package-vc--clone, package-vc--read-package-name, package-vc-install,
package-vc-checkout): Use vc-guess-backend.
* lisp/vc/vc (vc-backend-type, vc-heuristic-alist, vc-guess-backend):
... here.
---
lisp/emacs-lisp/package-vc.el | 77 ++++-------------------------------
lisp/vc/vc.el | 62 ++++++++++++++++++++++++++++
2 files changed, 71 insertions(+), 68 deletions(-)
diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el
index e168096e153..8746ebeb476 100644
--- a/lisp/emacs-lisp/package-vc.el
+++ b/lisp/emacs-lisp/package-vc.el
@@ -63,61 +63,9 @@ package-vc
(defconst package-vc--elpa-packages-version 1
"Version number of the package specification format understood by package-vc.")
-(defconst package-vc--backend-type
- `(choice :convert-widget
- ,(lambda (widget)
- (let (opts)
- (dolist (be vc-handled-backends)
- (when (or (vc-find-backend-function be 'clone)
- (alist-get 'clone (get be 'vc-functions)))
- (push (widget-convert (list 'const be)) opts)))
- (widget-put widget :args opts))
- widget))
- "The type of VC backends that support cloning package VCS repositories.")
-
-(defcustom package-vc-heuristic-alist
- `((,(rx bos "http" (? "s") "://"
- (or (: (? "www.") "github.com"
- "/" (+ (or alnum "-" "." "_"))
- "/" (+ (or alnum "-" "." "_")))
- (: "codeberg.org"
- "/" (+ (or alnum "-" "." "_"))
- "/" (+ (or alnum "-" "." "_")))
- (: (? "www.") "gitlab" (+ "." (+ alnum))
- "/" (+ (or alnum "-" "." "_"))
- "/" (+ (or alnum "-" "." "_")))
- (: "git.sr.ht"
- "/~" (+ (or alnum "-" "." "_"))
- "/" (+ (or alnum "-" "." "_")))
- (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/"
- (or "r" "git") "/"
- (+ (or alnum "-" "." "_")) (? "/")))
- (or (? "/") ".git") eos)
- . Git)
- (,(rx bos "http" (? "s") "://"
- (or (: "hg.sr.ht"
- "/~" (+ (or alnum "-" "." "_"))
- "/" (+ (or alnum "-" "." "_")))
- (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/"
- (+ (or alnum "-" "." "_")) (? "/")))
- eos)
- . Hg)
- (,(rx bos "http" (? "s") "://"
- (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/"
- (+ (or alnum "-" "." "_")) (? "/")))
- eos)
- . Bzr))
- "Alist mapping repository URLs to VC backends.
-`package-vc-install' consults this alist to determine the VC
-backend from the repository URL when you call it without
-specifying a backend. Each element of the alist has the form
-\(URL-REGEXP . BACKEND). `package-vc-install' will use BACKEND of
-the first association for which the URL of the repository matches
-the URL-REGEXP of the association. If no match is found,
-`package-vc-install' uses `package-vc-default-backend' instead."
- :type `(alist :key-type (regexp :tag "Regular expression matching URLs")
- :value-type ,package-vc--backend-type)
- :version "29.1")
+(define-obsolete-variable-alias
+ 'package-vc-heuristic-alist
+ 'vc-heuristic-alist "31.1")
(defcustom package-vc-default-backend 'Git
"Default VC backend to use for cloning package repositories.
@@ -127,7 +75,7 @@ package-vc-default-backend
The value must be a member of `vc-handled-backends' that supports
the `clone' VC function."
- :type package-vc--backend-type
+ :type vc-backend-type
:version "29.1")
(defcustom package-vc-register-as-project t
@@ -626,13 +574,6 @@ package-vc--unpack-1
"")))
t))
-(defun package-vc--guess-backend (url)
- "Guess the VC backend for URL.
-This function will internally query `package-vc-heuristic-alist'
-and return nil if it cannot reasonably guess."
- (and url (alist-get url package-vc-heuristic-alist
- nil nil #'string-match-p)))
-
(declare-function project-remember-projects-under "project" (dir &optional recursive))
(defun package-vc--clone (pkg-desc pkg-spec dir rev)
@@ -646,7 +587,7 @@ package-vc--clone
(unless (file-exists-p dir)
(make-directory (file-name-directory dir) t)
(let ((backend (or (plist-get pkg-spec :vc-backend)
- (package-vc--guess-backend url)
+ (vc-guess-backend url)
(plist-get (alist-get (package-desc-archive pkg-desc)
package-vc--archive-data-alist
nil nil #'string=)
@@ -753,7 +694,7 @@ package-vc--read-package-name
;; pointing towards a repository, and use that as a backup
(and-let* ((extras (package-desc-extras (cadr pkg)))
(url (alist-get :url extras))
- ((package-vc--guess-backend url)))))))
+ ((vc-guess-backend url)))))))
(not allow-url)))
(defun package-vc--read-package-desc (prompt &optional installed)
@@ -917,7 +858,7 @@ package-vc-install
(cdr package)
rev))
((and-let* (((stringp package))
- (backend (or backend (package-vc--guess-backend package))))
+ (backend (or backend (vc-guess-backend package))))
(package-vc--unpack
(package-desc-create
:name (or name (intern (file-name-base package)))
@@ -930,7 +871,7 @@ package-vc-install
(or (package-vc--desc->spec (cadr desc))
(and-let* ((extras (package-desc-extras (cadr desc)))
(url (alist-get :url extras))
- (backend (package-vc--guess-backend url)))
+ (backend (vc-guess-backend url)))
(list :vc-backend backend :url url))
(user-error "Package `%s' has no VC data" package))
rev)))
@@ -958,7 +899,7 @@ package-vc-checkout
(let ((pkg-spec (or (package-vc--desc->spec pkg-desc)
(and-let* ((extras (package-desc-extras pkg-desc))
(url (alist-get :url extras))
- (backend (package-vc--guess-backend url)))
+ (backend (vc-guess-backend url)))
(list :vc-backend backend :url url))
(user-error "Package `%s' has no VC data"
(package-desc-name pkg-desc)))))
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index 597a1622f5a..b27a3d3ed40 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -929,7 +929,69 @@ vc-find-revision-no-save
:type 'boolean
:version "27.1")
+(defconst vc-backend-type
+ `(choice :convert-widget
+ ,(lambda (widget)
+ (let (opts)
+ (dolist (be vc-handled-backends)
+ (when (or (vc-find-backend-function be 'clone)
+ (alist-get 'clone (get be 'vc-functions)))
+ (push (widget-convert (list 'const be)) opts)))
+ (widget-put widget :args opts))
+ widget))
+ "The type of VC backends that support cloning VCS repositories.")
+
+(defcustom vc-heuristic-alist
+ `((,(rx bos "http" (? "s") "://"
+ (or (: (? "www.") "github.com"
+ "/" (+ (or alnum "-" "." "_"))
+ "/" (+ (or alnum "-" "." "_")))
+ (: "codeberg.org"
+ "/" (+ (or alnum "-" "." "_"))
+ "/" (+ (or alnum "-" "." "_")))
+ (: (? "www.") "gitlab" (+ "." (+ alnum))
+ "/" (+ (or alnum "-" "." "_"))
+ "/" (+ (or alnum "-" "." "_")))
+ (: "git.sr.ht"
+ "/~" (+ (or alnum "-" "." "_"))
+ "/" (+ (or alnum "-" "." "_")))
+ (: "git." (or "savannah" "sv") "." (? "non") "gnu.org/"
+ (or "r" "git") "/"
+ (+ (or alnum "-" "." "_")) (? "/")))
+ (or (? "/") ".git") eos)
+ . Git)
+ (,(rx bos "http" (? "s") "://"
+ (or (: "hg.sr.ht"
+ "/~" (+ (or alnum "-" "." "_"))
+ "/" (+ (or alnum "-" "." "_")))
+ (: "hg." (or "savannah" "sv") "." (? "non") "gnu.org/hgweb/"
+ (+ (or alnum "-" "." "_")) (? "/")))
+ eos)
+ . Hg)
+ (,(rx bos "http" (? "s") "://"
+ (or (: "bzr." (or "savannah" "sv") "." (? "non") "gnu.org/r/"
+ (+ (or alnum "-" "." "_")) (? "/")))
+ eos)
+ . Bzr))
+ "Alist mapping repository URLs to VC backends.
+`vc-clone' consults this alist to determine the VC
+backend from the repository URL when you call it without
+specifying a backend. Each element of the alist has the form
+\(URL-REGEXP . BACKEND). `vc-clone' will use BACKEND of
+the first association for which the URL of the repository matches
+the URL-REGEXP of the association."
+ :type `(alist :key-type (regexp :tag "Regular expression matching URLs")
+ :value-type ,vc-backend-type)
+ :version "29.1")
+
\f
+(defun vc-guess-backend (url)
+ "Guess the VC backend for URL.
+This function will internally query `vc-heuristic-alist'
+and return nil if it cannot reasonably guess."
+ (and url (alist-get url vc-heuristic-alist
+ nil nil #'string-match-p)))
+
;; File property caching
(defun vc-clear-context ()
--
2.46.0
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: [PATCH] Make vc-clone interactive --]
[-- Type: text/x-patch, Size: 4725 bytes --]
From d8c1074e4a75d3e6f523f47cb239e9c8ae26b3b7 Mon Sep 17 00:00:00 2001
Message-ID: <d8c1074e4a75d3e6f523f47cb239e9c8ae26b3b7.1728225805.git.avityazev@disroot.org>
From: Aleksandr Vityazev <avityazev@disroot.org>
Date: Sun, 6 Oct 2024 17:34:59 +0300
Subject: [PATCH] Make vc-clone interactive
* lisp/vc/vc.el (vc-clone): Make interactive. Add optional
argument OPEN-DIR. Mention these changes in the doc string.
(vc--remotes-history): New defvar.
* etc/NEWS: Announce these changes.
---
etc/NEWS | 12 ++++++++++++
lisp/vc/vc.el | 54 +++++++++++++++++++++++++++++++++++++--------------
2 files changed, 51 insertions(+), 15 deletions(-)
diff --git a/etc/NEWS b/etc/NEWS
index d1bd469435f..8d902ccca5f 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -494,6 +494,18 @@ instead.
---
*** Support 'electric-layout-mode'.
+** VC
+
+*** 'vc-clone' is now an interactive command.
+When called interactively, 'vc-clone' now prompts for the remote
+repository address, the backend for cloning, if it has not been
+determined automatically according to the URL, and the directory to
+clone the repository into.
+
+*** 'vc-clone' now accepts an optional argument OPEN-DIR.
+When the argument is non-nil, the function switches to a buffer visiting
+directory to which the repository was cloned.
+
\f
* New Modes and Packages in Emacs 31.1
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index b27a3d3ed40..2f1d7808e7a 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -3866,7 +3866,9 @@ vc-check-headers
(interactive)
(vc-call-backend (vc-backend buffer-file-name) 'check-headers))
-(defun vc-clone (remote &optional backend directory rev)
+(defvar vc--remotes-history)
+
+(defun vc-clone (remote &optional backend directory rev open-dir)
"Clone repository REMOTE using version-control BACKEND, into DIRECTORY.
If successful, return the string with the directory of the checkout;
otherwise return nil.
@@ -3876,20 +3878,42 @@ vc-clone
If BACKEND is nil or omitted, the function iterates through every known
backend in `vc-handled-backends' until one succeeds to clone REMOTE.
If REV is non-nil, it indicates a specific revision to check out after
-cloning; the syntax of REV depends on what BACKEND accepts."
- (setq directory (expand-file-name (or directory default-directory)))
- (if backend
- (progn
- (unless (memq backend vc-handled-backends)
- (error "Unknown VC backend %s" backend))
- (vc-call-backend backend 'clone remote directory rev))
- (catch 'ok
- (dolist (backend vc-handled-backends)
- (ignore-error vc-not-supported
- (when-let ((res (vc-call-backend
- backend 'clone
- remote directory rev)))
- (throw 'ok res)))))))
+cloning; the syntax of REV depends on what BACKEND accepts.
+If OPEN-DIR is non-nil, switches to a buffer visiting DIRECTORY to
+which the repository was cloned. It would be useful in scripts, but not
+in regular code.
+If called interactively, prompt for REMOTE, DIRECTORY and BACKEND,
+if BACKEND has not been automatically determined according to the REMOTE
+URL, in the minibuffer."
+ (interactive
+ (let* ((url (read-string "Remote: " nil 'vc--remotes-history))
+ (backend (or (vc-guess-backend url)
+ (intern (completing-read
+ "Backend: " vc-handled-backends nil t)))))
+ (list url backend
+ (read-directory-name
+ "Clone into new or empty directory: " nil nil
+ (lambda (dir) (or (not (file-exists-p dir))
+ (directory-empty-p dir))))
+ nil t)))
+ (let* ((directory (expand-file-name (or directory default-directory)))
+ (backend (or backend (vc-guess-backend remote)))
+ (directory (if backend
+ (progn
+ (unless (memq backend vc-handled-backends)
+ (error "Unknown VC backend %s" backend))
+ (vc-call-backend backend 'clone remote directory rev))
+ (catch 'ok
+ (dolist (backend vc-handled-backends)
+ (ignore-error vc-not-supported
+ (when-let ((res (vc-call-backend
+ backend 'clone
+ remote directory rev)))
+ (throw 'ok res))))))))
+ (when (file-directory-p directory)
+ (when open-dir
+ (find-file directory))
+ directory)))
(declare-function log-view-current-tag "log-view" (&optional pos))
(defun vc-default-last-change (_backend file line)
--
2.46.0
[-- Attachment #4: Type: text/plain, Size: 38 bytes --]
--
Best regards,
Aleksandr Vityazev
next prev parent reply other threads:[~2024-10-06 14:50 UTC|newest]
Thread overview: 8+ messages / expand[flat|nested] mbox.gz Atom feed top
2024-09-19 13:18 bug#73357: [PATCH] Make vc-clone interactive Aleksandr Vityazev via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-09-19 13:36 ` Eli Zaretskii
2024-09-19 16:38 ` Aleksandr Vityazev via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-09-24 10:22 ` Philip Kaludercic
2024-09-29 18:23 ` Aleksandr Vityazev via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-10-01 11:09 ` Philip Kaludercic
2024-10-06 14:50 ` Aleksandr Vityazev via Bug reports for GNU Emacs, the Swiss army knife of text editors [this message]
2024-10-12 12:06 ` Eli Zaretskii
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87y131ffox.fsf@disroot.org \
--to=bug-gnu-emacs@gnu.org \
--cc=73357@debbugs.gnu.org \
--cc=avityazev@disroot.org \
--cc=eliz@gnu.org \
--cc=philipk@posteo.net \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).