Package: emacs;
Reported by: Aleksandr Vityazev <avityazev <at> disroot.org>
Date: Thu, 19 Sep 2024 13:19:01 UTC
Severity: normal
Tags: patch
Done: Sean Whitton <spwhitton <at> spwhitton.name>
Bug is archived. No further changes may be made.
Message #26 received at 73357 <at> debbugs.gnu.org (full text, mbox):
From: Eli Zaretskii <eliz <at> gnu.org> To: Aleksandr Vityazev <avityazev <at> disroot.org>, Dmitry Gutov <dmitry <at> gutov.dev> Cc: philipk <at> posteo.net, 73357 <at> debbugs.gnu.org Subject: Re: bug#73357: [PATCH] Make vc-clone interactive Date: Sat, 12 Oct 2024 15:06:49 +0300
> From: Aleksandr Vityazev <avityazev <at> disroot.org> > Cc: Eli Zaretskii <eliz <at> gnu.org>, 73357 <at> debbugs.gnu.org > Date: Sun, 06 Oct 2024 17:50:54 +0300 > > On 2024-10-01 11:09, Philip Kaludercic wrote: > > > Aleksandr Vityazev <avityazev <at> 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 <at> disroot.org> > >> From: Aleksandr Vityazev <avityazev <at> 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. > >> + > >> > >> * 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: Thanks. Dmitry, any comments, or should I install this?
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.