Subject: Re: bug#73357: [PATCH] Make vc-clone interactive

From: Aleksandr Vityazev <[email-masked]>
Date: Sun, 06 Oct 2024 17:50:54 +0300

On 2024-10-01 11:09, Philip Kaludercic wrote:

> Aleksandr Vityazev <[email-masked]> 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: <6[email-masked]>
>> From: Aleksandr Vityazev <[email-masked]>
>> 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.
>> +
>>  
>>  * 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")
>> +
>>  
>> +(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:

>From 0f2d2f91ca9ecfdf42e891a462ce4aa75e77a0ad Mon Sep 17 00:00:00 2001
Message-ID: <0[email-masked]>
From: Aleksandr Vityazev <[email-masked]>
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")
+
 
+(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

>From d8c1074e4a75d3e6f523f47cb239e9c8ae26b3b7 Mon Sep 17 00:00:00 2001
Message-ID: <d[email-masked]>
From: Aleksandr Vityazev <[email-masked]>
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.
+
 
 * 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

-- 
Best regards,
Aleksandr Vityazev