Re: cl-defstruct-based package.el, now with ert tests and no external tar!

[Stefan Monnier <monnier@iro.umontreal.ca>]

> I installed a patch which includes a part of your patch.

The last patch I installed includes further parts of your patch, tho
heavily reworked.
I think overall, this integrates most, if not all of your changes.

Trying to merge your patch with the current tip gives me a "residue" of
the following (fully untested, most probably broken) patch, FWIW.


        Stefan


Using changes with id "33".
Message: package.el patch from Hackney
 M  lisp/emacs-lisp/package.el
=== modified file 'lisp/emacs-lisp/package.el'
--- a/lisp/emacs-lisp/package.el	2013-06-21 04:19:53 +0000
+++ b/lisp/emacs-lisp/package.el	2013-06-21 04:20:02 +0000
@@ -418,6 +418,12 @@
 	  (pop str-list))
       (apply 'concat (nreverse str-list)))))
 
+(defun package-desc-install-dir (desc)
+  "Return the install directory of DESC."
+  (file-name-as-directory
+   (expand-file-name (package-desc-full-name desc)
+                     package-user-dir)))
+
 (defun package-load-descriptor (pkg-dir)
   "Load the description file in directory PKG-DIR."
   (let ((pkg-file (expand-file-name (package--description-file pkg-dir)
@@ -586,27 +592,26 @@
 ;; From Emacs 22, but changed so it adds to load-path.
 (defun package-autoload-ensure-default-file (file)
   "Make sure that the autoload file FILE exists and if not create it."
-  (unless (file-exists-p file)
-    (write-region
-     (concat ";;; " (file-name-nondirectory file)
-	     " --- automatically extracted autoloads\n"
-	     ";;\n"
-	     ";;; Code:\n"
-             "(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))\n"
-	     "\f\n;; Local Variables:\n"
-	     ";; version-control: never\n"
-	     ";; no-byte-compile: t\n"
-	     ";; no-update-autoloads: t\n"
-	     ";; End:\n"
-	     ";;; " (file-name-nondirectory file)
-	     " ends here\n")
-     nil file))
-  file)
+  (write-region
+   (concat ";;; " (file-name-nondirectory file)
+           " --- automatically extracted autoloads\n"
+           ";;\n"
+           ";;; Code:\n"
+           "(add-to-list 'load-path (or (file-name-directory #$) (car load-path)))\n"
+           "\f\n;; Local Variables:\n"
+           ";; version-control: never\n"
+           ";; no-byte-compile: t\n"
+           ";; no-update-autoloads: t\n"
+           ";; End:\n"
+           ";;; " (file-name-nondirectory file)
+           " ends here\n")
+   nil file))
 
-(defun package-generate-autoloads (name pkg-dir)
-  (require 'autoload)         ;Load before we let-bind generated-autoload-file!
-  (let* ((auto-name (format "%s-autoloads.el" name))
-	 ;;(ignore-name (concat name "-pkg.el"))
+(defun package-generate-autoloads (desc)
+  "Generate autoloads for package DESC."
+  (require 'autoload)         ;; Load before we let-bind generated-autoload-file!
+  (let* ((auto-name (format "%s-autoloads.el" (package-desc-name desc)))
+         (pkg-dir (package-desc-install-dir desc))
 	 (generated-autoload-file (expand-file-name auto-name pkg-dir))
 	 (version-control 'never))
     (package-autoload-ensure-default-file generated-autoload-file)
@@ -621,10 +626,8 @@
 (declare-function tar-header-link-type "tar-mode" (tar-header) t)
 
 (defun package-untar-buffer (dir)
-  "Untar the current buffer.
-This uses `tar-untar-buffer' from Tar mode.  All files should
-untar into a directory named DIR; otherwise, signal an error."
-  (require 'tar-mode)
+  "Untar the current buffer into DIR.
+This uses `tar-untar-buffer' from Tar mode."
   (tar-mode)
   ;; Make sure everything extracts into DIR.
   (let ((regexp (concat "\\`" (regexp-quote (expand-file-name dir)) "/"))
@@ -764,16 +767,15 @@
 
 (defvar package--initialized nil)
 
-(defun package-installed-p (package &optional min-version)
-  "Return true if PACKAGE, of MIN-VERSION or newer, is installed.
-MIN-VERSION should be a version list."
-  (unless package--initialized (error "package.el is not yet initialized!"))
-  (let ((pkg-desc (assq package package-alist)))
+(defun package-installed-p (name &optional min-version)
+  "Return true if NAME, of MIN-VERSION or newer, is installed.
+NAME must be a symbol and MIN-VERSION must be a version list."
+  (let ((pkg-desc (assq name package-alist)))
     (if pkg-desc
 	(version-list-<= min-version
 			 (package-desc-version (cdr pkg-desc)))
       ;; Also check built-in packages.
-      (package-built-in-p package min-version))))
+      (package-built-in-p name min-version))))
 
 (defun package-compute-transaction (package-list requirements)
   "Return a list of packages to be installed, including PACKAGE-LIST.
@@ -863,8 +865,6 @@
   "Re-read archive contents for ARCHIVE.
 If successful, set the variable `package-archive-contents'.
 If the archive version is too new, signal an error."
-  ;; Version 1 of 'archive-contents' is identical to our internal
-  ;; representation.
   (let* ((contents-file (format "archives/%s/archive-contents" archive))
 	 (contents (package--read-archive-file contents-file)))
     (when contents
@@ -917,7 +917,7 @@
                   (delq existing-package
                         package-archive-contents)))))))
 
-(defun package-download-transaction (package-list)
+(defun package-install-transaction (package-list)
   "Download and install all the packages in PACKAGE-LIST.
 PACKAGE-LIST should be a list of package names (symbols).
 This function assumes that all package requirements in
@@ -953,7 +953,9 @@
          (error "Package `%s' is not available for installation"
                 name))
        (list pkg-desc))))
-  (package-download-transaction
+  (unless package--initialized
+    (package-initialize t))
+  (package-install-transaction
    ;; FIXME: Use (list pkg-desc) instead of just the name.
    (package-compute-transaction (list (package-desc-name pkg-desc))
                                 (package-desc-reqs pkg-desc))))
@@ -980,9 +982,9 @@
   (unless (re-search-forward "^;;; \\([^ ]*\\)\\.el ---[ \t]*\\(.*?\\)[ \t]*\\(-\\*-.*-\\*-[ \t]*\\)?$" nil t)
     (error "Packages lacks a file header"))
   (let ((file-name (match-string-no-properties 1))
-	(desc      (match-string-no-properties 2))
-	(start     (line-beginning-position)))
-    (unless (search-forward (concat ";;; " file-name ".el ends here"))
+        (summary   (match-string-no-properties 2))
+        (start     (line-beginning-position)))
+    (unless (search-forward (format ";;; %s.el ends here"  file-name))
       (error "Package lacks a terminating comment"))
     ;; Try to include a trailing newline.
     (forward-line)
@@ -999,8 +1001,8 @@
 	(error
 	 "Package lacks a \"Version\" or \"Package-Version\" header"))
       (package-desc-from-define
-       file-name pkg-version desc
-       (if requires-str (package-read-from-string requires-str))
+       file-name pkg-version summary
+       (package-read-from-string requirements)
        :kind 'single))))
 
 (defun package-tar-file-info ()
@@ -1057,16 +1059,19 @@
     (package-install-from-buffer)))
 
 (defun package-delete (pkg-desc)
-  (let ((dir (package-desc-dir pkg-desc)))
-    (if (string-equal (file-name-directory dir)
-		      (file-name-as-directory
-		       (expand-file-name package-user-dir)))
-	(progn
-	  (delete-directory dir t t)
-	  (message "Package `%s' deleted." (package-desc-full-name pkg-desc)))
+  (let ((dir (package-desc-dir pkg-desc))
+        (full-name (package-desc-full-name pkg-desc)))
+    (cond
+     ((not (stringp dir))
+      (message "Package `%s' already deleted." full-name))
+     ((string-equal (file-name-directory dir)
+                    (file-name-as-directory
+                     (expand-file-name package-user-dir)))
+      (delete-directory dir t t)
+      (message "Package `%s' deleted." full-name))
+     (t
       ;; Don't delete "system" packages
-      (error "Package `%s' is a system package, not deleting"
-	     (package-desc-full-name pkg-desc)))))
+      (error "Package `%s' is a system package, not deleting" full-name))))
 
 (defun package-archive-base (desc)
   "Return the archive containing the package NAME."
@@ -1230,7 +1235,7 @@
 	(dolist (req reqs)
 	  (setq name (car req)
 		vers (cadr req)
-		text (format "%s-%s" (symbol-name name)
+		text (format "%s-%s" name
 			     (package-version-join vers)))
 	  (cond (first (setq first nil))
 		((>= (+ 2 (current-column) (length text))
@@ -1526,7 +1531,7 @@
   (let (installed available upgrades)
     ;; Build list of installed/available packages in this buffer.
     (dolist (entry tabulated-list-entries)
-      ;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC])
+      ;; ENTRY is (PKG-DESC [NAME VERSION-STRING STATUS DOC])
       (let ((pkg-desc (car entry))
 	    (status (aref (cadr entry) 2)))
 	(cond ((equal status "installed")
@@ -1621,12 +1626,10 @@
 		(package-delete elt)
 	      (error (message (cadr err)))))
 	(error "Aborted")))
-    ;; If we deleted anything, regenerate `package-alist'.  This is done
-    ;; automatically if we installed a package.
-    (and delete-list (null install-list)
-	 (package-initialize))
     (if (or delete-list install-list)
-	(package-menu--generate t t)
+        (progn
+          (package-initialize)
+          (package-menu--generate t t))
       (message "No operations specified."))))
 
 (defun package-menu--version-predicate (A B)
@@ -1698,15 +1701,16 @@
 	(package-menu--generate nil t))
       ;; The package menu buffer has keybindings.  If the user types
       ;; `M-x list-packages', that suggests it should become current.
-      (switch-to-buffer buf))
+      (switch-to-buffer buf)
 
-    (let ((upgrades (package-menu--find-upgrades)))
-      (if upgrades
-	  (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading."
-		   (length upgrades)
-		   (if (= (length upgrades) 1) "" "s")
-		   (substitute-command-keys "\\[package-menu-mark-upgrades]")
-		   (if (= (length upgrades) 1) "it" "them"))))))
+      (let ((upgrades (package-menu--find-upgrades)))
+        (if upgrades
+            (message "%d package%s can be upgraded; type `%s' to mark %s for upgrading."
+                     (length upgrades)
+                     (if (= (length upgrades) 1) "" "s")
+                     (substitute-command-keys "\\[package-menu-mark-upgrades]")
+                     (if (= (length upgrades) 1) "it" "them"))))
+      buf)))
 
 ;;;###autoload
 (defalias 'package-list-packages 'list-packages)