From 72279265b0d06603f74cf1e016db88997d078eba Mon Sep 17 00:00:00 2001 From: =?utf8?q?Gerd=20M=C3=B6llmann?= Date: Sun, 23 Oct 2022 13:21:25 +0200 Subject: [PATCH] More work on Lisp and tests --- lisp/emacs-lisp/pkg.el | 74 ++++++++++++++++++++++++++++++++++-------- test/src/pkg-tests.el | 68 +++++++++++++++++++------------------- 2 files changed, 94 insertions(+), 48 deletions(-) diff --git a/lisp/emacs-lisp/pkg.el b/lisp/emacs-lisp/pkg.el index 4258673d9f0..5e565228963 100644 --- a/lisp/emacs-lisp/pkg.el +++ b/lisp/emacs-lisp/pkg.el @@ -120,7 +120,10 @@ NAMES must be a list of package objects or valid package names." (mapcar #'(lambda (name) (pkg--find-or-make-package name)) names)) -(defun pkg-package-or-lose (name) +(defun pkg--package-or-lose (name) + "Return the package denoted by NAME. +If NAME is a package, return that. +Otherwise, NAME must be the name of a registered package." (if (packagep name) name (let ((pkg-name (pkg--stringify-name name "package"))) @@ -147,9 +150,13 @@ NAMES must be a list of package objects or valid package names." (package-%nicknames package))) (defun pkg--package-or-default (package) + "Return the package object denoted by PACKAGE. +If PACKAGE is a package object, return that. +If PACKAGE is nil, return the current package. +Otherwise assume that " (cond ((packagep package) package) ((null package) *package*) - (t (pkg-package-or-lose package)))) + (t (pkg--package-or-lose package)))) (defun pkg--symbol-listify (thing) (cond ((listp thing) @@ -161,6 +168,7 @@ NAMES must be a list of package objects or valid package names." (list thing)) (t (error "%s is neither a symbol nor a list of symbols" thing)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Basic stuff @@ -212,23 +220,29 @@ but is what Common Lisp implementations usually do." ;;;###autoload (defun package-name (package) - (package-%name (pkg-package-or-lose package))) + "Return the name of PACKAGE. +If PACKAGE is not a package object already, it must the name of a +registered package." + (package-%name (pkg--package-or-lose package))) ;;;###autoload (defun package-nicknames (package) - (package-%nicknames (pkg-package-or-lose package))) + "Return the list of nickname strings of PACKAGE. +If PACKAGE is not a package object already, it must the name of a +registered package." + (package-%nicknames (pkg--package-or-lose package))) ;;;###autoload (defun package-shadowing-symbols (package) - (package-%shadowing-symbols (pkg-package-or-lose package))) + (package-%shadowing-symbols (pkg--package-or-lose package))) ;;;###autoload (defun package-use-list (package) - (package-%use-list (pkg-package-or-lose package))) + (package-%use-list (pkg--package-or-lose package))) ;;;###autoload (defun package-used-by-list (package) - (let ((package (pkg-package-or-lose package)) + (let ((package (pkg--package-or-lose package)) ((used-by ()))) (dolist (p (list-all-packages)) (when (memq package (package-%use-list p)) @@ -237,6 +251,14 @@ but is what Common Lisp implementations usually do." ;;;###autoload (defun find-package (package) + "Find and return the package for PACKAGE. +If PACKAGE is a package object, return that. + +Otherwise, PACKAGE must be a package name, and that name +is lookup up in the package registry and the result is +returned if found. + +Value is nil if no package with the given name is found. " (if (packagep package) package (let ((name (pkg--stringify-name package "package name"))) @@ -244,27 +266,51 @@ but is what Common Lisp implementations usually do." ;;;###autoload (defun delete-package (package) + "Delete PACKAGE. + +If PACKAGE is an already deleted package, return nil. + +If PACKAGE is a package that is not already deleted, or PACKAGE +is a package name that is registered, delete that package by +removing it from the package registry, and return t. + +An attempt to delete one of the standard packages results in an +error." (if (and (packagep package) (null (package-%name package))) nil - (let ((package (pkg-package-or-lose package))) + (let ((package (pkg--package-or-lose package))) (when (or (eq package *emacs-package*) (eq package *keyword-package*)) - (error "Cannot delete standard package")) + (error "Cannot delete a standard package")) (pkg--remove-from-registry package) (setf (package-%name package) nil) t))) ;;;###autoload (defun rename-package (package new-name &optional new-nicknames) - (let ((package (pkg-package-or-lose package))) + "Replace name and nicknames of PACKAGE with NEW-NAME and NEW-NICKNAMES. + +PACKAGE must be a package object, or name a registered package. +Deleted packages cannot be renamed. + +NEW-NAME must be a valid package name, a string, symbol, or +character. + +Optional NEW-NICKSNAMES must be a list of valid package names. + +Value is the renamed package object." + (let ((package (pkg--package-or-lose package)) + (new-name (pkg--stringify-name new-name "package name")) + (new-nicknames (pkg--stringify-names new-nicknames + "package nickname"))) (unless (package-%name package) - ;; That's what CLHS says, and SBCL does... - (error "Cannot rename deleted package")) + (error "Package %s is deleted")) (pkg--remove-from-registry package) (setf (package-%nicknames package) new-nicknames) (setf (package-%name package) new-name) - (pkg--add-to-registry package))) + (pkg--add-to-registry package) + package)) ;;; Here... @@ -529,4 +575,6 @@ but is what Common Lisp implementations usually do." ;; ',shadows ',shadowing-imports ',(if use-p use :default) ;; ',imports ',interns ',exports ',doc)))) +(provide 'pkg) + ;;; pkg.el ends here diff --git a/test/src/pkg-tests.el b/test/src/pkg-tests.el index add6770d407..f769f8943ec 100644 --- a/test/src/pkg-tests.el +++ b/test/src/pkg-tests.el @@ -48,6 +48,8 @@ (ert-deftest pkg-tests-standard-packages () (should (packagep (find-package "emacs"))) + (should (packagep (find-package 'emacs))) + (should (packagep (find-package :emacs))) (should (packagep (find-package "keyword"))) (should (packagep (find-package ""))) (should (eq (find-package "keyword") (find-package "")))) @@ -86,6 +88,21 @@ ;; Duplicates removed, order-preserving. (should (equal (package-nicknames x) '("y" "z"))))) +(ert-deftest pkg-tests-package-name () + (should (equal (package-name (make-package "x")) "x")) + (should (equal (package-name (make-package :x)) "x")) + (should (equal (package-name "emacs") "emacs")) + (let ((p (make-package "x"))) + (delete-package p) + (should (null (package-name p)))) + (should-error (package-name 1))) + +(ert-deftest pkg-tests-package-nicknames () + (let ((nicknames '(("a" "b") (?a :b)))) + (dolist (n nicknames) + (let ((p (make-package "x" :nicknames n))) + (should (equal (package-nicknames p) '("a" "b"))))))) + (ert-deftest pkg-tests-list-all-packages () (let ((all (list-all-packages))) (should (cl-every #'packagep all)) @@ -93,17 +110,10 @@ (should (memq (find-package "keyword") all)) (should (memq (find-package "") all)))) -;; (ert-deftest pkg-tests-package-use-list () -;; (should nil)) - -;; (ert-deftest pkg-tests-package-used-by-list () -;; (should nil)) - -;; (ert-deftest pkg-tests-package-shadowing-symbols () -;; (should nil)) - (ert-deftest pkg-tests-package-find-package () (with-packages (x) + ;; If called with a package, returns that package. + (should (eq (find-package x) x)) (package-%register x) (should-error (find-package 1.0)) (should (eq (find-package 'x) x)) @@ -124,32 +134,20 @@ (should (null (package-name x))) (should (not (find-package 'x))))) -;; (with-packages (x) -;; (package-%register x) -;; (should (delete-package "x")) -;; (should-error (delete-package "x"))) -;; (let ((original (list-all-packages))) -;; (with-packages ((x :nicknames '(y))) -;; (should (delete-package x)) -;; (should (null (delete-package x))) -;; (should (not (find-package 'x))) -;; (should (not (find-package 'y)))))) - -;; (ert-deftest pkg-tests-rename-package () -;; (with-packages (x y) -;; (should (eq x (rename-package x 'a '(b)))) -;; (should (not (find-package 'x))) -;; (should (eq (find-package 'a) x)) -;; (should (eq (find-package 'b) x)) -;; ;; Can't rename to an existing name or nickname. -;; (should-error (rename-package y 'a)) -;; (should-error (rename-package y 'c :nicknames '("b"))) -;; ;; Original package name and nicknames are unchanged. -;; (should (equal (package-name x) "a")) -;; (should (equal (package-nicknames x) '("b"))) -;; ;; Can't rename deleted package. -;; (should (delete-package x)) -;; (should-error (rename-package x 'd)))) +(ert-deftest pkg-tests-rename-package () + (with-packages (x y) + (package-%register x) + (should (find-package 'x)) + (should (eq x (rename-package x 'a '(b)))) + (should (not (find-package 'x))) + (should (eq (find-package 'a) x)) + (should (eq (find-package 'b) x)) + ;; Can't rename to an existing name or nickname. + (should-error (rename-package y 'a)) + (should-error (rename-package y 'c :nicknames '("b"))) + ;; Can't rename deleted package. + (should (delete-package x)) + (should-error (rename-package x 'd)))) ;; (ert-deftest pkg-tests-find-symbol () ;; (should nil)) -- 2.39.2