commit 98f3bfe7e1cbd8bc43fcfd62bf985471aa255e34 Author: Sean Whitton Date: Thu Jun 25 17:59:51 2026 +0100 Factor out vc-dir--set-vc-dir-process-buffer * lisp/vc/vc-dir.el (vc-dir--set-vc-dir-process-buffer): New function, factored out. Also set vc-parent-buffer in the vc-dir-process-buffer. (vc-dir-refresh-files, vc-dir-refresh): Use it. diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 8f351f65c7f..189966e43f0 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -1651,6 +1651,19 @@ specific headers." (funcall fun vc-dir-backend (make-overlay (pos-eol) (pos-eol))))))) +(defun vc-dir--set-vc-dir-process-buffer (backend) + ;; Create a buffer that can be used by `dir-status' and call + ;; `dir-status' with this buffer as the current buffer. Use + ;; `vc-dir-process-buffer' to remember this buffer, so that it can be + ;; used later to kill the update process in case it takes too long. + (let ((buffer (current-buffer))) + (unless (buffer-live-p vc-dir-process-buffer) + (with-current-buffer + (setq vc-dir-process-buffer + (generate-new-buffer (format " *VC-%s* tmp status" + backend))) + (setq vc-parent-buffer buffer))))) + (defun vc-dir-refresh-files (files) "Refresh some FILES in the *VC-Dir* buffer." (let ((def-dir default-directory) @@ -1661,9 +1674,7 @@ specific headers." ;; It should compute the results, and then call the function ;; passed as an argument in order to update the vc-dir buffer ;; with the results. - (unless (buffer-live-p vc-dir-process-buffer) - (setq vc-dir-process-buffer - (generate-new-buffer (format " *VC-%s* tmp status" backend)))) + (vc-dir--set-vc-dir-process-buffer backend) (let ((buffer (current-buffer))) (with-current-buffer vc-dir-process-buffer (setq default-directory def-dir) @@ -1699,15 +1710,7 @@ Throw an error if another update process is in progress." ;; It should compute the results, and then call the function ;; passed as an argument in order to update the vc-dir buffer ;; with the results. - - ;; Create a buffer that can be used by `dir-status' and call - ;; `dir-status' with this buffer as the current buffer. Use - ;; `vc-dir-process-buffer' to remember this buffer, so that - ;; it can be used later to kill the update process in case it - ;; takes too long. - (unless (buffer-live-p vc-dir-process-buffer) - (setq vc-dir-process-buffer - (generate-new-buffer (format " *VC-%s* tmp status" backend)))) + (vc-dir--set-vc-dir-process-buffer backend) ;; set the needs-update flag on all non-directory entries (ewoc-map (lambda (info) (unless (vc-dir-fileinfo->directory info) commit e0327f345433110eac99fc9bda5ea4973c973d34 Author: Stephen Berman Date: Thu Jun 25 18:58:47 2026 +0200 VC Dir: don't mark directories with marked files (bug#81277) * lisp/vc/vc-dir.el (vc-dir-mark-all-files): When called on a directory entry that is marked, remove the mark. (vc-dir-unmark-file): When called on a file, at least one of whose ancestors (i.e. containing directory entries) is marked, unmark the nearest such ancestor and mark all descendents of that directory that are file entries, except the file entry on which the command is called, and leave the descendents that are directory entries unmarked. * test/lisp/vc/vc-tests/vc-test-misc.el (vc-test-vc-dir-next/previous) (vc-test-vc-dir-mark/unmark-all-dir-entry): Add bug number reference. (vc-test-vc-dir-mark-all-with-marked-directory): New test. (vc-test--vc-dir-unmark-file): New function. (vc-test-vc-dir-unmark-file-with-marked-directory): Use it in this new test. diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index fc9f34e0bf8..8f351f65c7f 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -928,6 +928,11 @@ share the same state." (if (vc-dir-fileinfo->directory data) ;; It's a directory, mark child files. (let (crt-data) + ;; First, if the directory itself is marked, unmark it, + ;; since we don't allow both a directory and its children to + ;; be marked. + (setf (vc-dir-fileinfo->marked data) nil) + (ewoc-invalidate vc-ewoc crt) (while (and (setq crt (ewoc-next vc-ewoc crt)) (setq crt-data (ewoc-data crt)) (not (vc-dir-fileinfo->directory crt-data))) @@ -1027,9 +1032,12 @@ Replace mark on `%s' with marks on all subitems but this one?" (setf (vc-dir-fileinfo->marked (ewoc-data parent)) nil) (push parent to-inval) (dolist (child all-children) - (setf (vc-dir-fileinfo->marked (ewoc-data child)) - (not (memq child subtree))) - (push child to-inval)))) + (let ((data (ewoc-data child))) + ;; Mark only file children, not directory children. + (unless (vc-dir-fileinfo->directory data) + (setf (vc-dir-fileinfo->marked data) + (not (memq child subtree))) + (push child to-inval)))))) ;; The current item is a directory that's not marked, implicitly ;; or explicitly, but it has marked items below it. ;; Offer to unmark those. diff --git a/test/lisp/vc/vc-tests/vc-test-misc.el b/test/lisp/vc/vc-tests/vc-test-misc.el index 049cef3c253..32c6b4d765d 100644 --- a/test/lisp/vc/vc-tests/vc-test-misc.el +++ b/test/lisp/vc/vc-tests/vc-test-misc.el @@ -298,7 +298,7 @@ See bug#80803 and bug#80967." (should (equal (vc-dir-fileinfo->state data) 'edited)))))))))) -(ert-deftest vc-test-vc-dir-next/previous () +(ert-deftest vc-test-vc-dir-next/previous () ; bug#81248 "Test navigating with `vc-dir-{next,previous}-{line,directory}'." (skip-unless (executable-find vc-git-program)) (vc-test--with-author-identity 'Git @@ -358,7 +358,7 @@ See bug#80803 and bug#80967." (should (and (looking-at "\\./$") (looking-back "^ +"))) (kill-buffer vc-dir-buf)))))) -(ert-deftest vc-test-vc-dir-mark/unmark-all-dir-entry () +(ert-deftest vc-test-vc-dir-mark/unmark-all-dir-entry () ; bug#81249 "Test `vc-dir-{un}mark-all' called on directory entry." (skip-unless (executable-find vc-git-program)) (vc-test--with-author-identity 'Git @@ -426,5 +426,102 @@ See bug#80803 and bug#80967." (should (seq-set-equal-p (vc-dir-marked-files) dir-children)))) (kill-buffer vc-dir-buf)))))) +(ert-deftest vc-test-vc-dir-mark-all-with-marked-directory () ; bug#81277 + "Test `vc-dir-mark-all' called on a marked directory entry." + (skip-unless (executable-find vc-git-program)) + (vc-test--with-author-identity 'Git + (let ((vc-handled-backends '(Git))) + (ert-with-temp-directory tempdir + (let ((default-directory tempdir) + (files '("dir1/file11" "dir1/file12")) + vc-dir-buf + dir-children) + (vc-test--create-repo-function 'Git) + (dolist (file files) + (make-empty-file file t)) + (vc-dir default-directory 'Git) + (while (vc-dir-busy) (sit-for 0.05)) + (setq vc-dir-buf (current-buffer)) + ;; Move point to "dir1/" entry line. + (goto-char (ewoc-location (ewoc-nth vc-ewoc 1))) + ;; Mark "dir1/". + (vc-dir-mark-file) + ;; Move back to "dir1/" entry. + (vc-dir-previous-line 1) + ;; Test that it's marked. + (should (vc-dir-fileinfo->marked (ewoc-data (ewoc-locate vc-ewoc)))) + (vc-dir-mark-all-files nil) + ;; Now it should have been unmarked. + (should-not + (vc-dir-fileinfo->marked (ewoc-data (ewoc-locate vc-ewoc)))) + ;; All its children should be marked. + (let ((dir-children (vc-dir-find-child-files + (expand-file-name + (vc-dir-fileinfo->name + (ewoc-data (ewoc-nth vc-ewoc 1))))))) + (should (seq-set-equal-p (vc-dir-marked-files) dir-children))) + (kill-buffer vc-dir-buf)))))) + +(defun vc-test--vc-dir-unmark-file () + "Execute `vc-dir-unmark-file' assuming \"y\" at `y-or-n-p' prompt." + (cl-letf (((symbol-function 'y-or-n-p) + (lambda (_prompt) t))) + (vc-dir-unmark-file))) + +(ert-deftest vc-test-vc-dir-unmark-file-with-marked-directory () ; bug#81277 + "Test `vc-dir-unmark-file' with a marked ancestor directory." + (skip-unless (executable-find vc-git-program)) + (vc-test--with-author-identity 'Git + (let ((vc-handled-backends '(Git))) + (ert-with-temp-directory tempdir + (let ((default-directory tempdir) + (files '("dir1/file11" "dir1/file12" + "dir1/dir2/file21" "dir1/dir2/file22" + "dir1/dir3/file31" "dir1/dir3/file32")) + vc-dir-buf unmarked directories) + (vc-test--create-repo-function 'Git) + (dolist (file files) + (make-empty-file file t)) + (vc-dir default-directory 'Git) + (while (vc-dir-busy) (sit-for 0.05)) + (setq vc-dir-buf (current-buffer)) + ;; Move point to "dir1/" entry line. + (goto-char (ewoc-location (ewoc-nth vc-ewoc 1))) + ;; Mark "dir1/". + (vc-dir-mark-file) + ;; On next entry simulate invoking `vc-dir-unmark-file' and + ;; answering "y" to `y-or-n-p' prompt. + (vc-test--vc-dir-unmark-file) + ;; Move back to that entry and test that it's unmarked. + (vc-dir-previous-line 1) + (should-not + (vc-dir-fileinfo->marked (ewoc-data (ewoc-locate vc-ewoc)))) + (push (expand-file-name + (vc-dir-fileinfo->name + (ewoc-data (ewoc-locate vc-ewoc)))) + unmarked) + ;; All other non-directory descendents of "dir1/" should be + ;; marked. + (let* ((dir-children (vc-dir-find-child-files + (expand-file-name + (vc-dir-fileinfo->name + (ewoc-data (ewoc-nth vc-ewoc 1)))))) + (rest-children (seq-difference dir-children unmarked))) + (should (seq-set-equal-p (vc-dir-marked-files) rest-children))) + ;; All directory entries should be unmarked. + (goto-char (point-max)) + (while (not (bobp)) + (vc-dir-previous-directory) + (push (expand-file-name + (vc-dir-fileinfo->name + (ewoc-data (ewoc-locate vc-ewoc)))) + directories) + (when (equal + (vc-dir-fileinfo->name (ewoc-data (ewoc-locate vc-ewoc))) + (vc-dir-fileinfo->name (ewoc-data (ewoc-nth vc-ewoc 1)))) + (goto-char (point-min)))) + (should-not (seq-intersection directories (vc-dir-marked-files))) + (kill-buffer vc-dir-buf)))))) + (provide 'vc-test-misc) ;;; vc-test-misc.el ends here commit 69b9018ed6faad5e3eccb36de47e6b43d1e52c27 Author: Sean Whitton Date: Thu Jun 25 17:53:34 2026 +0100 VC-Dir: Fix removing empty directory entries * lisp/vc/vc-dir.el (vc-dir-update): New CLEAR-OTHERS parameter. (vc-dir-refresh-files): Use it instead of calling ewoc-filter ourselves. diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 3d8e73a143d..fc9f34e0bf8 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -525,11 +525,13 @@ If BODY uses EVENT, it should be a variable, (defconst vc-dir--up-to-date-states '(up-to-date ignored)) -(defun vc-dir-update (entries buffer &optional noinsert) +(defun vc-dir-update (entries buffer &optional noinsert clear-others) "Update BUFFER's VC-Dir ewoc from ENTRIES. This has the effect of adding ENTRIES to the VC-Dir buffer BUFFER. If optional argument NOINSERT is non-nil, update ewoc nodes, but don't add elements of ENTRIES to the buffer that aren't already in the ewoc. +If optional argument CLEAR-OTHERS is non-nil, remove any remaining +entries we didn't update. Also update some VC file properties from ENTRIES." (with-current-buffer buffer ;; Insert the entries sorted by name into the ewoc. @@ -542,7 +544,7 @@ Also update some VC file properties from ENTRIES." (directory-file-name (expand-file-name (car entry)))) entry)) entries))) - ;; Sort: first files and then subdirectories. + ;; Sort: first files and then subdirectories. (mapcar #'cdr (sort entry-dirs (lambda (pair1 pair2) @@ -635,8 +637,15 @@ Also update some VC file properties from ENTRIES." ;; Now insert the node itself. (ewoc-enter-last vc-ewoc (apply #'vc-dir-create-fileinfo entry)))))) - (when to-remove - (let ((inhibit-read-only t) + (when clear-others + ;; Remove the ones that haven't been updated at all. + ;; Those not-updated are those whose state is nil because the + ;; file/dir doesn't exist and isn't versioned. + (ewoc-filter vc-ewoc + (lambda (info) + (not (vc-dir-fileinfo->needs-update info))))) + (when (or to-remove clear-others) + (let ((inhibit-read-only t) (crt (ewoc-nth vc-ewoc -1)) (first (ewoc-nth vc-ewoc 0))) (while (not (eq crt first)) @@ -1658,16 +1667,8 @@ specific headers." ;; If MORE-TO-COME is true, then more updates will come from ;; the asynchronous process. (with-current-buffer buffer - (vc-dir-update entries buffer) - (unless more-to-come - (setq mode-line-process nil) - ;; Remove the ones that haven't been updated at all. - ;; Those not-updated are those whose state is nil because the - ;; file/dir doesn't exist and isn't versioned. - (ewoc-filter vc-ewoc - (lambda (info) - (not - (vc-dir-fileinfo->needs-update info)))))))))))) + (vc-dir-update entries buffer nil (not more-to-come)) + (unless more-to-come (setq mode-line-process nil))))))))) (defun vc-dir-revert-buffer-function (&optional _ignore-auto _noconfirm) (vc-dir-refresh) @@ -1721,11 +1722,11 @@ Throw an error if another update process is in progress." (vc-dir-update entries buffer) (unless more-to-come (let ((remaining - (ewoc-collect - vc-ewoc 'vc-dir-fileinfo->needs-update))) + (ewoc-collect vc-ewoc + 'vc-dir-fileinfo->needs-update))) (if remaining - (vc-dir-refresh-files - (mapcar #'vc-dir-fileinfo->name remaining)) + (vc-dir-refresh-files (mapcar #'vc-dir-fileinfo->name + remaining)) (setq mode-line-process nil) (run-hooks 'vc-dir-refresh-hook)))))))))))) commit 13ce6f30832459d024b18fc5fcb455060646da09 Author: Sean Whitton Date: Thu Jun 25 17:40:08 2026 +0100 Make vc-dir-hide-state ignore the states of directory entries * lisp/vc/vc-dir.el (vc-dir-hide-state): Don't consider directory entries when removing based on state. (vc-dir-refresh-files): Remove old workaround. diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 393a2ebdbc3..3d8e73a143d 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -1666,17 +1666,8 @@ specific headers." ;; file/dir doesn't exist and isn't versioned. (ewoc-filter vc-ewoc (lambda (info) - ;; The state for directory entries might - ;; have been changed to 'up-to-date, - ;; reset it, otherwise it will be removed when doing 'x' - ;; next time. - ;; FIXME: There should be a more elegant way to do this. - (when (and (vc-dir-fileinfo->directory info) - (eq (vc-dir-fileinfo->state info) - 'up-to-date)) - (setf (vc-dir-fileinfo->state info) nil)) - - (not (vc-dir-fileinfo->needs-update info)))))))))))) + (not + (vc-dir-fileinfo->needs-update info)))))))))))) (defun vc-dir-revert-buffer-function (&optional _ignore-auto _noconfirm) (vc-dir-refresh) @@ -1782,10 +1773,11 @@ state of item at point, if any." (vc-dir-fileinfo->directory (ewoc-data next)))) ;; Remove files in specified STATE. STATE can be a ;; symbol, a user-name, or nil. - (let ((data-state (vc-dir-fileinfo->state data))) - (if state - (equal data-state state) - (memq data-state vc-dir--up-to-date-states)))) + (and (not dir) + (let ((data-state (vc-dir-fileinfo->state data))) + (if state + (equal data-state state) + (memq data-state vc-dir--up-to-date-states))))) (ewoc-delete vc-ewoc crt)) (setq crt prev))))) commit b66c995d5fb060b79bf866aa8d760ff0857ae32e Author: Stephen Berman Date: Thu Jun 25 18:05:02 2026 +0200 Improve 'vc-dir-unmark-all-files' (bug#81249) * lisp/vc/vc-dir.el (vc-dir-unmark-all-files): Confine the scope of this command, when called on a VC Dir directory entry, to the immediate child files of that directory. This is in accordance with the command's doc string and makes it behave analgously to 'vc-dir-mark-all-files', whose behavior was change to be like this much earlier. * test/lisp/vc/vc-tests/vc-test-misc.el (vc-test-vc-dir-mark/unmark-all-dir-entry): New test. diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 596c2fe7362..393a2ebdbc3 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -1079,11 +1079,12 @@ that share the same state." (data (ewoc-data crt))) (if (vc-dir-fileinfo->directory data) ;; It's a directory, unmark child files. - (while (setq crt (ewoc-next vc-ewoc crt)) - (let ((crt-data (ewoc-data crt))) - (unless (vc-dir-fileinfo->directory crt-data) - (setf (vc-dir-fileinfo->marked crt-data) nil) - (ewoc-invalidate vc-ewoc crt)))) + (let (crt-data) + (while (and (setq crt (ewoc-next vc-ewoc crt)) + (setq crt-data (ewoc-data crt)) + (not (vc-dir-fileinfo->directory crt-data))) + (setf (vc-dir-fileinfo->marked crt-data) nil) + (ewoc-invalidate vc-ewoc crt))) ;; It's a file (let ((crt-state (vc-dir-fileinfo->state (ewoc-data crt)))) (ewoc-map diff --git a/test/lisp/vc/vc-tests/vc-test-misc.el b/test/lisp/vc/vc-tests/vc-test-misc.el index 83a69867220..049cef3c253 100644 --- a/test/lisp/vc/vc-tests/vc-test-misc.el +++ b/test/lisp/vc/vc-tests/vc-test-misc.el @@ -358,5 +358,73 @@ See bug#80803 and bug#80967." (should (and (looking-at "\\./$") (looking-back "^ +"))) (kill-buffer vc-dir-buf)))))) +(ert-deftest vc-test-vc-dir-mark/unmark-all-dir-entry () + "Test `vc-dir-{un}mark-all' called on directory entry." + (skip-unless (executable-find vc-git-program)) + (vc-test--with-author-identity 'Git + (let ((vc-handled-backends '(Git))) + (ert-with-temp-directory tempdir + (let ((default-directory tempdir) + (files '("file01" "file02" "dir1/file11" "dir1/file12" + "dir2/file21" "dir2/file22")) + vc-dir-buf + dir-children) + (vc-test--create-repo-function 'Git) + (dolist (file files) + (make-empty-file file t)) + (vc-dir default-directory 'Git) + (while (vc-dir-busy) (sit-for 0.05)) + (setq vc-dir-buf (current-buffer)) + ;; Put point on line of "./" entry. + (goto-char (ewoc-location (ewoc-nth vc-ewoc 0))) + ;; Cumulatively mark file entries directory-wise. + (let ((next t)) + (while next + (vc-dir-mark-all-files nil) + ;; Can't use this to set dir-children because it returns + ;; all files below directory entry, so loop over file + ;; entries until next directory entry. + ;; (vc-dir-find-child-files + ;; (expand-file-name + ;; (vc-dir-fileinfo->name + ;; (ewoc-data (ewoc-locate vc-ewoc))))) + (catch 'done + (while t + (vc-dir-next-line 1) + (cond ((vc-dir-fileinfo->directory + (ewoc-data (ewoc-locate vc-ewoc))) + (throw 'done nil)) + ;; After last entry. + ((looking-at "^$") + (throw 'done (setq next nil))) + (t + (push (expand-file-name + (vc-dir-fileinfo->name + (ewoc-data (ewoc-locate vc-ewoc)))) + dir-children))))) + (should (seq-set-equal-p (vc-dir-marked-files) dir-children)))) + (goto-char (ewoc-location (ewoc-nth vc-ewoc 0))) + ;; Cumulatively unmark file entries directory-wise. + (let ((next t)) + (while next + (vc-dir-unmark-all-files nil) + (catch 'done + (while t + (vc-dir-next-line 1) + (cond ((vc-dir-fileinfo->directory + (ewoc-data (ewoc-locate vc-ewoc))) + (throw 'done nil)) + ;; After last entry. + ((looking-at "^$") + (throw 'done (setq next nil))) + (t + (setq dir-children + (delete (expand-file-name + (vc-dir-fileinfo->name + (ewoc-data (ewoc-locate vc-ewoc)))) + dir-children)))))) + (should (seq-set-equal-p (vc-dir-marked-files) dir-children)))) + (kill-buffer vc-dir-buf)))))) + (provide 'vc-test-misc) ;;; vc-test-misc.el ends here commit 5e28bcb2d8fc7f7ae3d66868ddfe6d05e15b4bfe Author: Stephen Berman Date: Thu Jun 25 17:39:45 2026 +0200 Improve vc-dir-next-* commands (bug#81248) * lisp/vc/vc-dir.el (vc-dir--before-dotname-p): New function. (vc-dir-next-line, vc-dir-next-directory): Use it to enable using these commands to move point to the VC Dir root directory entry "./". * test/lisp/vc/vc-tests/vc-test-misc.el (vc-test-vc-dir-next/previous): New test. diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 57a7488825e..596c2fe7362 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -710,12 +710,27 @@ information." t) t)) +;; By design the vc-dir-next-* commands move point from the current +;; entry to the next one of the same type. But for technical reasons +;; any buffer position before the "./" entry is part of that entry, so +;; there is no previous entry from which to move via vc-dir-next-* to +;; this entry. But from the UX perspective such movement is natural, so +;; we enable it by making these commands move point directly to the "./" +;; entry (instead of the "next" one) whenever point is before this +;; entry, as determined by the following function. See bug#81248 for +;; further details. +(defun vc-dir--before-dotname-p () + "Return non-nil if point is before the \"./\" entry." + (< (point) (ewoc-location (ewoc-nth vc-ewoc 0)))) + (defun vc-dir-next-line (arg) "Go to the next line. With prefix argument ARG, move that many lines." (interactive "p") (with-no-warnings - (ewoc-goto-next vc-ewoc arg) + (if (vc-dir--before-dotname-p) + (ewoc-goto-node vc-ewoc (ewoc-nth vc-ewoc 0)) + (ewoc-goto-next vc-ewoc arg)) (vc-dir-move-to-goal-column))) (defun vc-dir-previous-line (arg) @@ -732,7 +747,9 @@ With prefix argument ARG, move that many lines." (if (catch 'foundit (while t - (let* ((next (ewoc-next vc-ewoc (ewoc-locate vc-ewoc)))) + (let* ((next (if (vc-dir--before-dotname-p) + (ewoc-nth vc-ewoc 0) + (ewoc-next vc-ewoc (ewoc-locate vc-ewoc))))) (cond ((not next) (throw 'foundit t)) (t diff --git a/test/lisp/vc/vc-tests/vc-test-misc.el b/test/lisp/vc/vc-tests/vc-test-misc.el index 066c49df324..83a69867220 100644 --- a/test/lisp/vc/vc-tests/vc-test-misc.el +++ b/test/lisp/vc/vc-tests/vc-test-misc.el @@ -298,5 +298,65 @@ See bug#80803 and bug#80967." (should (equal (vc-dir-fileinfo->state data) 'edited)))))))))) +(ert-deftest vc-test-vc-dir-next/previous () + "Test navigating with `vc-dir-{next,previous}-{line,directory}'." + (skip-unless (executable-find vc-git-program)) + (vc-test--with-author-identity 'Git + (let ((vc-handled-backends '(Git))) + (ert-with-temp-directory tempdir + (let ((default-directory tempdir) + (n 0) + vc-dir-buf) + (vc-test--create-repo-function 'Git) + (dolist (file '("file01" "dir1/file11")) + (make-empty-file file t)) + (vc-dir default-directory 'Git) + (while (vc-dir-busy) (sit-for 0.05)) + (setq vc-dir-buf (current-buffer)) + (should (bobp)) + (while (vc-dir--before-dotname-p) + (vc-dir-next-line 1) + (should (and (looking-at "\\./$") (looking-back "^ +"))) + (incf n 1) + (goto-char (point-min)) + (forward-line n)) + (vc-dir-next-line 1) + (should (looking-at "file01$")) + (vc-dir-next-line 1) + (should (looking-at "dir1/$")) + (vc-dir-next-line 1) + (should (looking-at "dir1/file11$")) + (vc-dir-next-line 1) + (should (looking-at "^$")) + (let ((end (point))) + (vc-dir-next-line 1) + (should (equal (point) end))) + (goto-char (point-min)) + (vc-dir-next-directory) + (should (and (looking-at "\\./$") (looking-back "^ +"))) + (vc-dir-next-directory) + (should (and (looking-at "dir1/$") (looking-back "^ +"))) + (vc-dir-next-directory) + (should (and (looking-at "dir1/$") (looking-back "^ +"))) + (goto-char (point-max)) + (vc-dir-previous-line 1) + (should (looking-at "dir1/file11$")) + (vc-dir-previous-line 1) + (should (and (looking-at "dir1/$") (looking-back "^ +"))) + (vc-dir-previous-line 1) + (should (looking-at "file01$")) + (vc-dir-previous-line 1) + (should (and (looking-at "\\./$") (looking-back "^ +"))) + (vc-dir-previous-line 1) + (should (and (looking-at "\\./$") (looking-back "^ +"))) + (goto-char (point-max)) + (vc-dir-previous-directory) + (should (and (looking-at "dir1/$") (looking-back "^ +"))) + (vc-dir-previous-directory) + (should (and (looking-at "\\./$") (looking-back "^ +"))) + (vc-dir-previous-directory) + (should (and (looking-at "\\./$") (looking-back "^ +"))) + (kill-buffer vc-dir-buf)))))) + (provide 'vc-test-misc) ;;; vc-test-misc.el ends here commit c9da3c1a5edaf2812c87358947dccc0d7336e93e Author: Filipp Gunbin Date: Thu Jun 25 11:48:12 2026 +0200 'insert-directory': Make 'ls' error buffer read-only * lisp/files.el (insert-directory): Set 'buffer-read-only' to t for buffer "*ls error*", since it is only an informational buffer, and let-bind 'inhibit-read-only' to t to write any 'ls' error message to it (bug#80499, Message #230 and followups). diff --git a/lisp/files.el b/lisp/files.el index 97144fef78f..149a3e80866 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -8488,8 +8488,10 @@ normally equivalent short `-D' option is just passed on to (defvar dired--ls-error-buffer) ; Pacify byte-compiler. (let ((errbuf (get-buffer-create "*ls error*"))) (with-current-buffer errbuf - (erase-buffer) - (insert-file-contents errfile)) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert-file-contents errfile))) (setq dired--ls-error-buffer errbuf))) (defvar dired--ls-error-file) ; Pacify byte-compiler. (setq dired--ls-error-file errfile) commit 5a110cad82451e90c63be00c8b98e562cbf5bd06 Author: Eli Zaretskii Date: Thu Jun 25 10:11:16 2026 +0300 ; * doc/lispref/elisp.texi (Top): Update @detailmenu. diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 9115b3a4691..eb697c1da38 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -1453,6 +1453,7 @@ Processes * Misc Network:: Additional relevant functions for net connections. * Serial Ports:: Communicating with serial ports. * Byte Packing:: Using bindat to pack and unpack binary data. +* UUIDs:: Generating and converting UUIDs. Receiving Output from Processes commit bd064471e6aaf6348f52e66c3d34d7050695f21b Author: Andrew Hyatt Date: Sat Jun 13 18:08:53 2026 -0400 New package uuid.el * lisp/emacs-lisp/uuid.el: New file. * test/lisp/emacs-lisp/uuid-tests.el: New tests. * doc/lispref/processes.texi (UUIDs): New section. diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index b340067592f..bc4fcdbe27a 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -68,6 +68,7 @@ Processes}. * Misc Network:: Additional relevant functions for net connections. * Serial Ports:: Communicating with serial ports. * Byte Packing:: Using bindat to pack and unpack binary data. +* UUIDs:: Generating and converting UUIDs. @end menu @node Subprocess Creation @@ -3883,3 +3884,154 @@ arguments @var{args}. Its behavior follows that of @code{defmacro}, which the important difference that the new forms can only be used within Bindat type expressions. @end defmac + +@node UUIDs +@section UUIDs +@cindex uuids + + Emacs Lisp can generate and parse the most popular UUID variants to +and from strings and binary. It can generate UUIDv4, UUIDv5 and UUIDv7 +according to RFC 9562. UUIDv4 is a randomly generated identifier, +UUIDv5 is an identifier generated from a standard namespace and a name, +and UUIDv7 is a combination of a timestamp and random identifier, with +the advantage of having good index performance in databases. + +All UUIDs are 16 byte identifiers with a common string representation, +consisting of hex digits and dashes of a predetermined length, such as +@samp{919108f7-52d1-4320-9bac-f847db4148a8}. + +@menu +* UUID Generation:: +* UUID Conversion:: +* Special UUID values:: +@end menu + +@node UUID Generation +@subsection UUID Generation +@cindex uuid generation + + To generate UUIDs, call @code{uuid-v4}, @code{uuid-v5} or +@code{uuid-v7}. UUID v4 and v7 will by default use the normal elisp +@dfn{random} for random numbers, but a different random number generator +can be passed in, as long as it can be called with an arg of the end of +the range of acceptable integers to generate (exclusive), and returns an +integer. + +@defun uuid-v4 &key rng +Return a @code{uuid-v4} Lisp object representing a new UUIDv4. +@var{rng}, if provided, is a function that will, when called with a +numeric argument, return a random number between 0 and that number +(exclusive). +@end defun + +@defun uuid-v7 &key rng +Similar to @code{uuid-v4} but returns a @code{uuid-v7}, which is +generated with a timestamp in addition to random numbers (generated from +@var{rng} in a similar manner as @code{uuid-v4}). +@end defun + +These use random numbers, which should be cryptographically secure. +@xref{Random Numbers}, but generally these random numbers are not +sufficient to generate sufficiently random UUIDs. For private uses, the +default behavior should be sufficient, but for professional uses, +@var{rng} should be used, and provide cryptographically secure random +numbers. + +@noindent +UUIDv5s must be created with a namespace and a name. The namespaces are +defined in @code{uuid-namespace-alist} and are by default @code{dns}, +@code{url}, @code{oid}, and @code{x500}. + +@defun uuid-v5 namespace name +This function returns a new @code{uuid-v5} Lisp object based on +@var{namespace}, which is a symbol in the key of the +@code{uuid-namespace-alist}: @code{dns}, @code{url}, @code{oid}, +@code{x500}, or any symbol added. This is combined with @var{name} to +construct a new UUIDv5. +@end defun + +An example is: + +@cindex uuidv5 +@example +(uuid-v5 'dns "www.example.com") +@end example + +@defvar uuid-namespace-alist +A list of namespace symbols and their corresponding UUIDs. Each alist +entry is a cons of the symbol and a UUID Lisp object representing the +namespace. This is used in @code{uuid-v5}, see above for more info on +how this is used. +@end defvar + +@node UUID Conversion +@subsection UUID Conversion +@cindex uuid conversion + +To use a UUID, typically it is converted to a string, and sometimes to a +binary representation. This is done using @code{uuid-to-string} function. + +@defun uuid-to-string uuid +Return the standard string value, with hex values and dashes, of Lisp +object @code{uuid}. +@end defun + +@example +(uuid-to-string (uuid-v4)) ; @r{"230156d4-488a-45d1-93c9-507ec8be37ca"} +@end example + +@noindent +Binary can also be generated, which generates a unibyte string, using +@code{uuid-to-bytes}, and a numeric representation of a UUID can be +generated with @code{uuid-to-number}. + +@defun uuid-to-bytes uuid +Return a unibyte string representing the binary value of @code{uuid}. +@end defun + +@defun uuid-to-number uuid +Return a numeric representation of the value of @code{uuid}. +@end defun + +@noindent +String UUIDs can also be converted to a UUID Lisp object, with +@code{uuid-from-string}, and bytes can be converted with +@code{uuid-from-bytes}. These work with all UUIDs, not just the ones +this module can generate. + +@defun uuid-from-string uuid-str +Return a UUID Lisp object that represents @var{uuid-str}. +@end defun + +@defun uuid-from-bytes uuid-bytes +Return a UUID Lisp object that represents @var{uuid-bytes}, which is +expected to be a unibyte string. +@end defun + +Valid UUIDs have types, which can be used with @code{cl-typep}, +@code{cl-check-type} and @code{cl-typecase}. The type is specified with +the type specifier @code{(uuid-v )}. @var{version} can be any +version of UUID, but we make sure the UUID variant is correctly +@code{2}; any other value is not a valid version. + +@example +(when (cl-typep my-uuid '(uuid-v 4)) + (process-v4-uuid my-uuid)) + +(defun process-v4-uuid (uuid) + ;; Error if not the correct type + (cl-check-type uuid (uuid-v 4)) + ;; Proceed to process the UUIDv4. + (more-processing uuid)) +@end example + +@node Special UUID values +@subsection Special UUID values +@cindex special uuid values +@cindex uuid nil and uuid max +@cindex nil uuid +@cindex max uuid + +@code{uuid-nil} and @code{uuid-max} are constant values representing the +UUID equivalents of @code{nil} and a max sentinel value, as defined in +RFC 9562. diff --git a/lisp/emacs-lisp/uuid.el b/lisp/emacs-lisp/uuid.el new file mode 100644 index 00000000000..592751a427e --- /dev/null +++ b/lisp/emacs-lisp/uuid.el @@ -0,0 +1,245 @@ +;;; uuid.el --- UUID creation and handling -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Free Software Foundation, Inc. + +;; Author: Andrew Hyatt +;; Keywords: tools + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + + +;;; Commentary: +;; This library provides useful code for handling UUIDs. It provides +;; methods for generating UUIDs, parsing them, and outputting them as +;; a string, a unibyte binary string, or as a number. +;; +;;; Code: + +(require 'cl-lib) +(require 'bindat) +(require 'seq) + +(define-error + 'uuid-invalid-string + "Invalid UUID string not conforming to expected UUID shape.") + +(define-error + 'uuid-invalid-bytes + "Invalid UUID bytes not conforming to expected 16-byte length.") + +(define-error + 'uuid-invalid-namespace + "Namespace not found in `uuid-namespace-alist'.") + +(defconst uuid--bindat-type + (bindat-type (:high uint 48) + ;; We can't separate out ver and mid due to bindat + ;; limitations on byte alignment. + (:ver-mid uint 16) + ;; Same issue with var and low. + (:var-low uint 64)) + "The bindat type for UUIDs, as defined in RFC 9562.") + +(cl-defstruct (uuid + (:constructor nil) + (:conc-name uuid--) + (:constructor + uuid--from-parts + (high mid low ver var))) + "The base type for all UUIDs. + +This will represent versions where we don't have a more specific version +defined, so all versions except for v4, v5, and v7." + high mid low ver var) + +(defun uuid--upper-bits (num n bitsize) + "Return the upper N bits of NUM of BITSIZE. + +BITSIZE is the total size of the num." + (ash num (- n bitsize))) + +(defun uuid--lower-bits (num n) + "Return the lower N bits of NUM." + (logand num (- (ash 1 n) 1))) + +(defun uuid--concat-bits (&rest num-and-sizes) + "Return number doing bitwise concatenating NUM-AND-SIZES. + +NUM-AND-SIZES is a list of alternating numbers and their sizes in bits." + (cl-loop for num-and-size in (reverse + (seq-partition num-and-sizes 2)) + with shift = 0 + sum (ash (car num-and-size) shift) + do (incf shift (cadr num-and-size)))) + +(defun uuid-to-string (id) + "Convert the uuid object ID to a string." + (let ((low (uuid--low id)) + (high (uuid--high id))) + (format "%08x-%04x-%04x-%04x-%012x" + (uuid--upper-bits high 32 48) + (uuid--lower-bits high 16) + (uuid--concat-bits + (uuid--ver id) 4 + (uuid--mid id) 12) + (uuid--concat-bits + (uuid--var id) 2 + (uuid--upper-bits low 14 62) 14) + (uuid--lower-bits low 48)))) + +(defun uuid-to-bytes (id) + "Convert the uuid object ID to a 16-byte unibyte string." + (bindat-pack uuid--bindat-type + `((:high . ,(uuid--high id)) + (:ver-mid . ,(uuid--concat-bits + (uuid--ver id) 4 + (uuid--mid id) 12)) + (:var-low . ,(uuid--concat-bits + (uuid--var id) 2 + (uuid--low id) 62))))) + +(defun uuid-to-number (id) + "Convert ID, a `uuid' lisp object, to a numerical representation." + (uuid--concat-bits + (uuid--high id) 48 + (uuid--ver id) 4 + (uuid--mid id) 12 + (uuid--var id) 2 + (uuid--low id) 62)) + +(defconst uuid-nil + (uuid--from-parts 0 0 0 0 0) + "A UUID representing `nil', as defined in RFC 9562.") + +(defconst uuid-max + (uuid--from-parts (1- (ash 1 48)) (1- (ash 1 12)) (1- (ash 1 62)) 15 3) + "A UUID representing the maximum UUID, per RFC 9562.") + +(cl-deftype uuid-v (var) + `(and uuid (satisfies + ,(lambda (id) (and (= (uuid--ver id) var) + (= (uuid--var id) 2)))))) + +(defun uuid--random-bits (n &optional rng) + "Return a random number with N bits." + (funcall (or rng #'random) + (expt 2 n))) + +(defun uuid-from-string (uuid-str) + "Parse UUID-STR and return the appropriate UUID object." + (let* ((parts (split-string uuid-str "-")) + (_ (unless (and (= (length parts) 5) + (= (length (nth 0 parts)) 8) + (= (length (nth 1 parts)) 4) + (= (length (nth 2 parts)) 4) + (= (length (nth 3 parts)) 4) + (= (length (nth 4 parts)) 12) + (string-match "^[0-9a-fA-F-]+$" uuid-str)) + (signal 'uuid-invalid-string (list uuid-str)))) + (hex-parts (mapcar (lambda (part) (string-to-number part 16)) parts)) + (version (uuid--upper-bits (nth 2 hex-parts) 4 16)) + (variant (uuid--upper-bits (nth 3 hex-parts) 2 16)) + (high (uuid--concat-bits + (nth 0 hex-parts) 32 + (nth 1 hex-parts) 16)) + (mid (uuid--lower-bits (nth 2 hex-parts) 12)) + (low + (uuid--concat-bits + (uuid--lower-bits (nth 3 hex-parts) 14) 14 + (nth 4 hex-parts) 48))) + (uuid--from-parts high mid low version variant))) + +(defun uuid-from-bytes (uuid-bytes) + "Parse unibyte string UUID-BYTES and return a UUID object. + +If UUID-BYTES are not unibyte, or not 16 bytes, a `uuid-invalid-bytes' +error is signaled." + (unless (and + (not (multibyte-string-p uuid-bytes)) + (= 16 (string-bytes uuid-bytes))) + (signal 'uuid-invalid-bytes (list uuid-bytes))) + (let* ((parts (bindat-unpack uuid--bindat-type uuid-bytes)) + (version (uuid--upper-bits (assoc-default :ver-mid parts) 4 16)) + (variant (uuid--upper-bits (assoc-default :var-low parts) 2 64)) + (high (assoc-default :high parts)) + (mid (uuid--lower-bits (assoc-default :ver-mid parts) 12)) + (low (uuid--lower-bits (assoc-default :var-low parts) 62))) + (uuid--from-parts high mid low version variant))) + +(defconst uuid-namespace-alist + (mapcar (lambda (x) (cons (car x) (uuid-from-string (cdr x)))) + '((dns . "6ba7b810-9dad-11d1-80b4-00c04fd430c8") + (url . "6ba7b811-9dad-11d1-80b4-00c04fd430c8") + (oid . "6ba7b812-9dad-11d1-80b4-00c04fd430c8") + (x500 . "6ba7b814-9dad-11d1-80b4-00c04fd430c8"))) + "An alist of namespaces and their canonical UUIDs. + This is defined at https://www.rfc-editor.org/info/rfc9562/#namespaces.") + +(cl-defun uuid-v4 (&key rng) + "Return a new UUIDv4 ID. + +RNG is an alternate random number function which should take a single +argument, the limit (exclusive) for the random number, and return an +integer between 0 and that number. To be valid according to RFC 9562, +the random numbers should be cryptographically secure, which the default +random number generator typically is not, so if these UUIDs are +important, it's advised to use a better random number function, which +typically requires getting random numbers from outside of Emacs." + (uuid--from-parts (uuid--random-bits 48 rng) + (uuid--random-bits 12 rng) + (uuid--random-bits 62 rng) + 4 2)) + +(defun uuid-v5 (namespace name) + "Return a new UUIDv5 ID from the given NAMESPACE and NAME. + +NAMESPACE should be a symbol corresponding to a namespace in +`uuid-namespace-alist'. If this is not recognized it will signal an +`uuid-invalid-namespace' signal. + +NAME is the name from which to generate the UUID, and should be a +string." + (let* ((namespace-uuid (or + (alist-get namespace uuid-namespace-alist) + (signal 'uuid-invalid-namespace (list namespace)))) + (hash-bytes (sha1 + (concat + (uuid-to-bytes namespace-uuid) + (encode-coding-string name 'utf-8)) + nil nil t)) + (hash-vals (bindat-unpack uuid--bindat-type hash-bytes))) + (uuid--from-parts (assoc-default :high hash-vals) + (uuid--lower-bits (assoc-default :ver-mid hash-vals) 12) + (uuid--lower-bits (assoc-default :var-low hash-vals) 62) + 5 2))) + +(cl-defun uuid-v7 (&key rng) + "Return a new UUIDv7 ID. + +The UUIDv7 uses a timestamp instead of being purely random, which makes +it more suitable for use cases such as database keys. + +RNG is an alternate random number function which should take a single +argument, the limit (exclusive) for the random number, and return an +integer between 0 and that number. See `uuid-v4' for more details on +the expected behavior of this function." + (uuid--from-parts (floor (* (float-time) 1000)) + (uuid--random-bits 12 rng) + (uuid--random-bits 62 rng) + 7 2)) + +(provide 'uuid) +;;; uuid.el ends here diff --git a/test/lisp/emacs-lisp/uuid-tests.el b/test/lisp/emacs-lisp/uuid-tests.el new file mode 100644 index 00000000000..e2631e49079 --- /dev/null +++ b/test/lisp/emacs-lisp/uuid-tests.el @@ -0,0 +1,175 @@ +;; uuid-tests.el --- unit tests for uuid.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Free Software Foundation, Inc. + +;; Author: Andrew Hyatt + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; Unit tests for uuid.el. + +;;; Code: + +(require 'uuid) + +(ert-deftest uuid-v4-input () + "Verifies that a UUID-V4 can be parsed and detected correctly." + ;; Example comes from RFC 9562, A.3. + (let ((id (uuid-from-string "919108f7-52d1-4320-9bac-f847db4148a8"))) + (should (cl-typep id '(uuid-v 4))) + (should (equal (uuid-to-string id) "919108f7-52d1-4320-9bac-f847db4148a8")) + (should (equal (uuid--high id) #x919108f752d1)) + (should (equal (uuid--mid id) #x320)) + (should (equal (uuid--low id) #x1bacf847db4148a8)) + (should (equal (uuid--var id) 2)) + (should (equal (uuid--ver id) 4)))) + +(ert-deftest uuid-v4-generator () + "Verifies that a generated UUID-V4 is valid." + (let ((id (uuid-v4))) + (should (cl-typep id '(uuid-v 4))) + (should (equal (uuid--var id) 2)) + (should (equal (uuid--ver id) 4)))) + +(ert-deftest uuid-v4-generator-custom-rnd () + "Verifies that a UUID-V4 uses the RND function provided to it." + (let ((id (uuid-v4 :rng (lambda (n) 23)))) + (should (cl-typep id '(uuid-v 4))) + (should (equal (uuid--var id) 2)) + (should (equal (uuid--ver id) 4)) + (should (equal (uuid--high id) 23)) + (should (equal (uuid--mid id) 23)) + (should (equal (uuid--low id) 23)))) + +(ert-deftest uuid-v5-input () + "Verifies that a UUIDv5 can be parsed and detected correctly." + ;; Example comes from RFC 9562, A.4. + (let ((id (uuid-from-string "2ed6657d-e927-568b-95e1-2665a8aea6a2"))) + (should (cl-typep id '(uuid-v 5))) + (should (equal (uuid-to-string id) "2ed6657d-e927-568b-95e1-2665a8aea6a2")) + (should (equal (uuid--high id) #x2ed6657de927)) + (should (equal (uuid--mid id) #x68b)) + (should (equal (uuid--low id) #x015e12665a8aea6a2)) + (should (equal (uuid--var id) 2)) + (should (equal (uuid--ver id) 5)))) + +(ert-deftest uuid-v5-generator () + "Verifies that a UUIDv5 can be generated correctly." + ;; Example comes from RFC 9562, A.4. + (let ((id (uuid-v5 'dns "www.example.com"))) + (should (cl-typep id '(uuid-v 5))) + (should (equal (uuid-to-string id) "2ed6657d-e927-568b-95e1-2665a8aea6a2")) + (should (equal (uuid--high id) #x2ed6657de927)) + (should (equal (uuid--mid id) #x68b)) + (should (equal (uuid--low id) #x015e12665a8aea6a2)))) + +(ert-deftest uuid-v5-invalid-namespace () + "Verifies an invalid namespace errors out." + (should-error (uuid-v5 'invalid "www.example.com") + :type 'uuid-invalid-namespace)) + +(ert-deftest uuid-v7-input () + "Verifies that a UUIDv7 can be parsed and detected correctly." + ;; Example comes from RFC 9562, A.5. + (let ((id (uuid-from-string "017f22e2-79b0-7cc3-98c4-dc0c0c07398f"))) + (should (cl-typep id '(uuid-v 7))) + (should (equal (uuid-to-string id) "017f22e2-79b0-7cc3-98c4-dc0c0c07398f")) + (should (equal (uuid--high id) #x017f22e279b0)) + (should (equal (uuid--mid id) #xcc3)) + (should (equal (uuid--low id) #x18c4dc0c0c07398f)) + (should (equal (uuid--var id) 2)) + (should (equal (uuid--ver id) 7)))) + +(ert-deftest uuid-v7-generator () + "Verifies that a UUIDv7 can be generated correctly." + (let ((id (uuid-v7))) + (should (cl-typep id '(uuid-v 7))) + (should (equal (uuid--var id) 2)) + (should (equal (uuid--ver id) 7)))) + +(ert-deftest uuid-v7-generator-known-rnd-and-ts () + "Verifies that a UUIDv7 uses random, timestamps correctly." + (cl-letf (((symbol-function 'float-time) + (lambda () 0.123))) + (let ((id (uuid-v7 :rng (lambda (n) 789)))) + (should (cl-typep id '(uuid-v 7))) + (should (equal (uuid--var id) 2)) + (should (equal (uuid--ver id) 7)) + ;; 123 = 0x7b + ;; 789 = 0x315 + (should (equal (uuid-to-string id) "00000000-007b-7315-8000-000000000315"))))) + +(ert-deftest uuid-bytes () + "Verifies that a UUID can be converted to bytes and back." + (let* ((id (uuid-v4)) + (bytes (uuid-to-bytes id)) + (id2 (uuid-from-bytes bytes))) + (should (equal id id2)) + (should (= (length bytes) 16)) + (should-not (multibyte-string-p bytes)))) + +(ert-deftest uuid-to-number () + "Test UUIDs can convert into the correct number." + (should (equal 193491124287564075115561252409011423400 + (uuid-to-number (uuid-from-string "919108f7-52d1-4320-9bac-f847db4148a8"))))) + +(ert-deftest uuid-invalid-string () + "Verifies that an invalid UUID string is rejected." + (should-error (uuid-from-string "invaluuid-string") + :type 'uuid-invalid-string) + ;; Too short + (should-error (uuid-from-string "017f22e2-79b0-7cc3-98c4-dc0c0c07398") + :type 'uuid-invalid-string) + ;; Too long + (should-error (uuid-from-string "017f22e2-79b0-7cc3-98c4-dc0c0c07398ff")) + ;; Not valid hex + (should-error (uuid-from-string "017f22e2-79b0-7cc3-98c4-dc0c0c07398zz"))) + +(ert-deftest uuid-invalid-bytes () + "Verifies that an invalid UUID byte string is rejected." + (should-error (uuid-from-bytes "short-bytes") + :type 'uuid-invalid-bytes) + ;; Too long + (should-error (uuid-from-bytes (make-string 17 ?\0))) + ;; Multibyte + (should-error (uuid-from-bytes (encode-coding-string (make-string 17 ?\0) 'utf-8)))) + +(ert-deftest uuid-unsupported-version () + "Verifies that non v4,5, or 7 versions are a usable UUID." + (dolist (uuid-str + '("017f22e2-79b0-8cc3-98c4-dc0c0c07398f" ;; UUIDv8 + "d5103018-6530-328e-b76b-9132edeba856" ;; UUIDv3 + "358f9528-5e27-11f1-b58b-def57c109056" ;; UUIDv1 + )) + (let* ((id (uuid-from-string uuid-str))) + (should (equal id (uuid-from-bytes (uuid-to-bytes id)))) + (should (uuid-p id)) + (dolist (v '(4 5 7)) + (should-not (cl-typep id `(uuid-v ,v)))) + (should (equal (uuid-to-string id) uuid-str))))) + +(ert-deftest uuid-nil () + "Tests the nil UUID handling." + (should (equal (uuid-to-string uuid-nil) "00000000-0000-0000-0000-000000000000")) + (should (equal 0 (uuid-to-number uuid-nil)))) + +(ert-deftest uuid-max () + "Tests the max UUID handling." + (should (equal (uuid-to-string uuid-max) "ffffffff-ffff-ffff-ffff-ffffffffffff")) + (should (= 340282366920938463463374607431768211455 (uuid-to-number uuid-max)))) + +;;; uuid-tests.el ends here