diff options
| -rw-r--r-- | modules/vc-config.el | 47 | ||||
| -rw-r--r-- | tests/test-vc-config--git-clone.el | 88 |
2 files changed, 122 insertions, 13 deletions
diff --git a/modules/vc-config.el b/modules/vc-config.el index c76e714e..45aec73b 100644 --- a/modules/vc-config.el +++ b/modules/vc-config.el @@ -137,6 +137,17 @@ interactive selection to jump to any changed line in the buffer." ;; Quick git clone from clipboard URL ;; Based on: https://xenodium.com/bending-emacs-episode-3-git-clone-the-lazy-way +(defun cj/--git-clone-dir-name (url) + "Return the repository directory name implied by git clone URL. +Handles HTTPS, scp-style SSH (git@host:user/repo.git or host:repo.git), +ssh:// URLs, and local paths by taking the last path component — splitting +on both `/' and `:' so scp-style URLs without a `/' work — and stripping a +trailing .git. `file-name-nondirectory' alone mishandles the colon-only +scp form." + (let* ((trimmed (string-trim url)) + (last (car (last (split-string trimmed "[/:]" t))))) + (and last (file-name-sans-extension last)))) + (defun cj/git-clone-clipboard-url (url target-dir) "Clone git repository from clipboard URL to TARGET-DIR. @@ -144,7 +155,11 @@ With no prefix argument: uses first directory in `cj/git-clone-dirs'. With \\[universal-argument]: choose from `cj/git-clone-dirs'. With \\[universal-argument] \\[universal-argument]: choose any directory. -After cloning, opens the repository's README file if found." +Clones with a direct `git' process (no shell), into a path derived +robustly from URL. Aborts with a clear message when the clipboard is +empty, the target is not a writable directory, the destination already +exists, or `git' exits non-zero. After a successful clone, opens the +repository's README if found, else `dired's the clone." (interactive (list (current-kill 0) ;; Get URL from clipboard (cond @@ -157,20 +172,26 @@ After cloning, opens the repository's README file if found." ;; No prefix: Use default (first in list) (t (car cj/git-clone-dirs))))) - (let* ((default-directory target-dir) - (repo-name (file-name-sans-extension - (file-name-nondirectory url))) - (clone-dir (expand-file-name repo-name target-dir))) - - ;; Clone the repository - (message "Cloning %s to %s..." url target-dir) - (shell-command (format "git clone %s" (shell-quote-argument url))) - - ;; Find and open README - (when (file-directory-p clone-dir) + (let ((url (string-trim (or url "")))) + (when (string-empty-p url) + (user-error "Clipboard does not contain a URL to clone")) + (unless (and (file-directory-p target-dir) (file-writable-p target-dir)) + (user-error "Clone target is not a writable directory: %s" target-dir)) + (let ((clone-dir (expand-file-name (cj/--git-clone-dir-name url) target-dir))) + (when (file-exists-p clone-dir) + (user-error "Clone destination already exists: %s" clone-dir)) + (message "Cloning %s into %s..." url clone-dir) + ;; Direct process, no shell. `--' stops option parsing so a URL + ;; beginning with `-' can't be read as a git flag. + (let ((status (call-process "git" nil "*git-clone*" nil + "clone" "--" url clone-dir))) + (unless (zerop status) + (pop-to-buffer "*git-clone*") + (user-error "git clone failed (exit %d); see *git-clone*" status))) + ;; Find and open README (let ((readme (seq-find (lambda (file) - (string-match-p "^README" (upcase file))) + (string-match-p "\\`README" (upcase file))) (directory-files clone-dir)))) (if readme (find-file (expand-file-name readme clone-dir)) diff --git a/tests/test-vc-config--git-clone.el b/tests/test-vc-config--git-clone.el new file mode 100644 index 00000000..3b39ece2 --- /dev/null +++ b/tests/test-vc-config--git-clone.el @@ -0,0 +1,88 @@ +;;; test-vc-config--git-clone.el --- Tests for clipboard git-clone hardening -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for cj/--git-clone-dir-name (robust repo-dir derivation across +;; HTTPS, scp-style SSH, ssh:// and local URLs) and for cj/git-clone-clipboard-url +;; reporting a failed clone from the process exit status instead of silently +;; assuming the directory appeared. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'vc-config) + +;;; cj/--git-clone-dir-name — Normal Cases + +(ert-deftest test-vc-git-clone-dir-name-https-with-git-suffix () + "Normal: an HTTPS URL with a .git suffix yields the bare repo name." + (should (equal "repo" + (cj/--git-clone-dir-name "https://example.com/user/repo.git")))) + +(ert-deftest test-vc-git-clone-dir-name-https-without-git-suffix () + "Normal: an HTTPS URL without a .git suffix yields the bare repo name." + (should (equal "repo" + (cj/--git-clone-dir-name "https://example.com/user/repo")))) + +(ert-deftest test-vc-git-clone-dir-name-ssh-scp-with-user () + "Normal: scp-style SSH with a user path yields the repo name." + (should (equal "repo" + (cj/--git-clone-dir-name "git@example.com:user/repo.git")))) + +(ert-deftest test-vc-git-clone-dir-name-ssh-url-scheme () + "Normal: an ssh:// URL yields the repo name." + (should (equal "repo" + (cj/--git-clone-dir-name "ssh://git@example.com/user/repo.git")))) + +;;; Boundary Cases + +(ert-deftest test-vc-git-clone-dir-name-ssh-scp-without-user () + "Boundary: scp-style SSH with no user path (host:repo.git) still works. +This is the case the old file-name-nondirectory derivation got wrong, +since there is no `/' separator." + (should (equal "repo" + (cj/--git-clone-dir-name "git@example.com:repo.git")))) + +(ert-deftest test-vc-git-clone-dir-name-local-path () + "Boundary: a local filesystem path yields the repo name." + (should (equal "repo" + (cj/--git-clone-dir-name "/home/me/src/repo.git")))) + +(ert-deftest test-vc-git-clone-dir-name-trailing-slash () + "Boundary: a trailing slash does not swallow the repo name." + (should (equal "repo" + (cj/--git-clone-dir-name "https://example.com/user/repo.git/")))) + +(ert-deftest test-vc-git-clone-dir-name-surrounding-whitespace () + "Boundary: clipboard whitespace around the URL is trimmed." + (should (equal "repo" + (cj/--git-clone-dir-name " https://example.com/user/repo.git\n")))) + +;;; cj/git-clone-clipboard-url — Error Cases + +(ert-deftest test-vc-git-clone-clipboard-url-reports-clone-failure () + "Error: a nonzero git exit status surfaces a user-error, not silence. +Uses a real writable temp dir as the target (so the file predicates run +for real) and mocks only the clone process to fail." + (let ((target (make-temp-file "cj-clone-fail-" t))) + (unwind-protect + (cl-letf (((symbol-function 'call-process) (lambda (&rest _) 128)) + ((symbol-function 'pop-to-buffer) #'ignore) + ((symbol-function 'message) #'ignore)) + (should-error + (cj/git-clone-clipboard-url "https://example.com/user/repo.git" target) + :type 'user-error)) + (delete-directory target t)))) + +(ert-deftest test-vc-git-clone-clipboard-url-empty-clipboard-errors () + "Error: an empty clipboard URL aborts before any clone attempt." + (let ((cloned nil)) + (cl-letf (((symbol-function 'call-process) + (lambda (&rest _) (setq cloned t) 0))) + (should-error (cj/git-clone-clipboard-url " " "/tmp") :type 'user-error)) + (should-not cloned))) + +(provide 'test-vc-config--git-clone) +;;; test-vc-config--git-clone.el ends here |