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

From: Philip Kaludercic <[email-masked]>
Date: Tue, 01 Oct 2024 11:09:12 +0000

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.

> ---
>  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'!

>  (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?

> +      (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

-- 
	Philip Kaludercic on icterid