Subject: bug#13291: The package description buffer needs an URL button

From: Dmitry Gutov <[email-masked]>
Date: Wed, 07 Aug 2013 12:54:40 +0300

Here's an updated patch for package, package-x and tests.

Please comment, I'd like to install it soon-ish.

Notes:

* Converting from plist to alist and back is a hassle, but it gives us 
an opportunity to clear out keys with nil values in 
`package-desc-from-define'.
* Not passing :homepage to `package-desc-from-define' in 
`package-buffer-info' when its value is nil seems hard.
* `package--add-to-archive-contents' tries to retain backward 
compatibility by checking the given vector's length.

Now we just need a package archive that would include homepage information.
=== modified file 'lisp/ChangeLog'
--- lisp/ChangeLog	2013-08-06 12:18:43 +0000
+++ lisp/ChangeLog	2013-08-07 09:14:53 +0000
@@ -1,3 +1,22 @@
+2013-08-07  Dmitry Gutov  <[email-masked]>
+
+	* emacs-lisp/package.el (package-desc-from-define): Accept
+	additional arguments as plist, convert it to an alist and store it
+	in the `extras' slot.
+	(package-generate-description-file): Convert extras alist back to
+	plist and append to the `define-package' form arguments.
+	(package--alist-to-plist): New function.
+	(package--ac-desc): Add `extras' slot.
+	(package--add-to-archive-contents): Check if the archive-contents
+	vector is long enough, and if it is, pass its `extras' slot value
+	to `package-desc-create'.
+	(package-buffer-info): Call `lm-homepage', pass the returned value
+	to `package-desc-from-define'.
+	(describe-package-1): Render the homepage button.
+
+	* emacs-lisp/package-x.el (package-upload-buffer-internal): Pass
+	`extras' slot from `package-desc' to `package-make-ac-desc'.
+
 2013-08-06  Juanma Barranquero  <[email-masked]>
 
 	* frameset.el (frameset, frameset-filter-alist)

=== modified file 'lisp/emacs-lisp/package-x.el'
--- lisp/emacs-lisp/package-x.el	2013-06-27 09:26:54 +0000
+++ lisp/emacs-lisp/package-x.el	2013-08-07 08:31:50 +0000
@@ -209,6 +209,7 @@
                 (pcase file-type
                   (`single (lm-commentary))
                   (`tar nil))) ;; FIXME: Get it from the README file.
+               (extras (package-desc-extras pkg-desc))
 	       (pkg-version (package-version-join split-version))
 	       (pkg-buffer (current-buffer)))
 
@@ -217,7 +218,7 @@
 	  (let ((contents (or (package--archive-contents-from-url archive-url)
 			      (package--archive-contents-from-file)))
 		(new-desc (package-make-ac-desc
-                           split-version requires desc file-type)))
+                           split-version requires desc file-type extras)))
 	    (if (> (car contents) package-archive-version)
 		(error "Unrecognized archive version %d" (car contents)))
 	    (let ((elt (assq pkg-name (cdr contents))))

=== modified file 'lisp/emacs-lisp/package.el'
--- lisp/emacs-lisp/package.el	2013-08-03 02:34:22 +0000
+++ lisp/emacs-lisp/package.el	2013-08-07 08:51:42 +0000
@@ -296,7 +296,7 @@
                (:constructor
                 package-desc-from-define
                 (name-string version-string &optional summary requirements
-                 &key kind archive &allow-other-keys
+                 &rest rest-plist
                  &aux
                  (name (intern name-string))
                  (version (version-to-list version-string))
@@ -305,7 +305,19 @@
                                          (version-to-list (cadr elt))))
                                (if (eq 'quote (car requirements))
                                    (nth 1 requirements)
-                                 requirements))))))
+                                 requirements)))
+                 (kind (plist-get rest-plist :kind))
+                 (archive (plist-get rest-plist :archive))
+                 (extras (let (alist)
+                           (cl-remf rest-plist :kind)
+                           (cl-remf rest-plist :archive)
+                           (while rest-plist
+                             (let ((value (cadr rest-plist)))
+                               (when value
+                                 (push (cons (car rest-plist) value)
+                                       alist)))
+                             (setq rest-plist (cddr rest-plist)))
+                           alist)))))
   "Structure containing information about an individual package.
 Slots:
 
@@ -327,14 +339,17 @@
 	package came.
 
 `dir'	The directory where the package is installed (if installed),
-	`builtin' if it is built-in, or nil otherwise."
+	`builtin' if it is built-in, or nil otherwise.
+
+`extras' Optional alist of additional keyword-value pairs."
   name
   version
   (summary package--default-summary)
   reqs
   kind
   archive
-  dir)
+  dir
+  extras)
 
 ;; Pseudo fields.
 (defun package-desc-full-name (pkg-desc)
@@ -635,22 +650,28 @@
       (write-region
        (concat
         (prin1-to-string
-         (list 'define-package
-               (symbol-name name)
-               (package-version-join (package-desc-version pkg-desc))
-               (package-desc-summary pkg-desc)
-               (let ((requires (package-desc-reqs pkg-desc)))
-                 (list 'quote
-                       ;; Turn version lists into string form.
-                       (mapcar
-                        (lambda (elt)
-                          (list (car elt)
-                                (package-version-join (cadr elt))))
-                        requires)))))
+         (nconc
+          (list 'define-package
+                (symbol-name name)
+                (package-version-join (package-desc-version pkg-desc))
+                (package-desc-summary pkg-desc)
+                (let ((requires (package-desc-reqs pkg-desc)))
+                  (list 'quote
+                        ;; Turn version lists into string form.
+                        (mapcar
+                         (lambda (elt)
+                           (list (car elt)
+                                 (package-version-join (cadr elt))))
+                         requires))))
+          (package--alist-to-plist
+           (package-desc-extras pkg-desc))))
         "\n")
        nil
        pkg-file))))
 
+(defun package--alist-to-plist (alist)
+  (apply #'nconc (mapcar (lambda (pair) (list (car pair) (cdr pair))) alist)))
+
 (defun package-unpack (pkg-desc)
   "Install the contents of the current buffer as a package."
   (let* ((name (package-desc-name pkg-desc))
@@ -886,10 +907,10 @@
 ;; Changing this defstruct implies changing the format of the
 ;; "archive-contents" files.
 (cl-defstruct (package--ac-desc
-               (:constructor package-make-ac-desc (version reqs summary kind))
+               (:constructor package-make-ac-desc (version reqs summary kind extras))
                (:copier nil)
                (:type vector))
-  version reqs summary kind)
+  version reqs summary kind extras)
 
 (defun package--add-to-archive-contents (package archive)
   "Add the PACKAGE from the given ARCHIVE if necessary.
@@ -904,7 +925,11 @@
            :reqs (package--ac-desc-reqs (cdr package))
            :summary (package--ac-desc-summary (cdr package))
            :kind (package--ac-desc-kind (cdr package))
-           :archive archive))
+           :archive archive
+           :extras (and (> (length (cdr package)) 4)
+                        ;; Older archive-contents files have only 4
+                        ;; elements here.
+                        (package--ac-desc-extras (cdr package)))))
          (existing-packages (assq name package-archive-contents))
          (pinned-to-archive (assoc name package-pinned-packages)))
     (cond
@@ -997,14 +1022,16 @@
 	   ;; probably wants us to use it.  Otherwise try Version.
 	   (pkg-version
 	    (or (package-strip-rcs-id (lm-header "package-version"))
-		(package-strip-rcs-id (lm-header "version")))))
+		(package-strip-rcs-id (lm-header "version"))))
+           (homepage (lm-homepage)))
       (unless pkg-version
 	(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))
-       :kind 'single))))
+       :kind 'single
+       :homepage homepage))))
 
 (declare-function tar-get-file-descriptor "tar-mode" (file))
 (declare-function tar--extract "tar-mode" (descriptor))
@@ -1173,6 +1200,8 @@
          (reqs (if desc (package-desc-reqs desc)))
          (version (if desc (package-desc-version desc)))
          (archive (if desc (package-desc-archive desc)))
+         (homepage (if desc (cdr (assoc :homepage
+                                        (package-desc-extras desc)))))
          (built-in (eq pkg-dir 'builtin))
          (installable (and archive (not built-in)))
          (status (if desc (package-desc-status desc) "orphan")))
@@ -1241,7 +1270,10 @@
 	(insert "\n")))
     (insert "    " (propertize "Summary" 'font-lock-face 'bold)
 	    ": " (if desc (package-desc-summary desc)) "\n")
-
+    (when homepage
+      (insert "   " (propertize "Homepage" 'font-lock-face 'bold) ": ")
+      (help-insert-xref-button homepage 'help-url homepage)
+      (insert "\n"))
     (let* ((all-pkgs (append (cdr (assq name package-alist))
                              (cdr (assq name package-archive-contents))
                              (let ((bi (assq name package--builtins)))

=== modified file 'test/ChangeLog'
--- test/ChangeLog	2013-08-05 01:32:00 +0000
+++ test/ChangeLog	2013-08-07 09:43:50 +0000
@@ -1,3 +1,29 @@
+2013-08-07  Dmitry Gutov  <[email-masked]>
+
+	* automated/package-test.el (simple-single-desc-1-4): Remove, it
+	was unused.
+	(simple-single-desc): Expect :homepage property.
+	(multi-file-desc): Same.
+	(with-package-test): Do not save previous `default-directory'
+	value, let-bind the var instead.
+	(package-test-install-single): Expect :homepage property in the
+	generated pkg file.
+	(package-test-describe-package): Expect Homepage button.
+	(package-test-describe-non-installed-package)
+	(package-test-describe-non-installed-multi-file-package): Same.
+	(package-test-describe-not-installed-package): Remove, it was a
+	duplicate.
+
+	* automated/package-x-test.el
+	(package-x-test--single-archive-entry-1-3): Expect :homepage
+	property.
+	(package-x-test--single-archive-entry-1-4): Expect nil extras slot.
+
+	* automated/data/package/simple-single-1.3.el: Add URL header.
+
+	* automated/data/package/archive-contents: Add :homepage
+	properties to `simple-single' and `multi-file'.
+
 2013-08-05  Glenn Morris  <[email-masked]>
 
 	* automated/mule-util.el: New file, with tests extracted from

=== modified file 'test/automated/data/package/archive-contents'
--- test/automated/data/package/archive-contents	2013-06-27 09:26:54 +0000
+++ test/automated/data/package/archive-contents	2013-08-07 08:37:09 +0000
@@ -1,10 +1,12 @@
 (1
  (simple-single .
                 [(1 3)
-                 nil "A single-file package with no dependencies" single])
+                 nil "A single-file package with no dependencies" single
+                 ((:homepage . "http://doodles.au"))])
  (simple-depend .
                 [(1 0)
                  ((simple-single (1 3))) "A single-file package with a dependency." single])
  (multi-file .
              [(0 2 3)
-              nil "Example of a multi-file tar package" tar]))
+              nil "Example of a multi-file tar package" tar
+              ((:homepage . "http://puddles.li"))]))

=== modified file 'test/automated/data/package/multi-file-0.2.3.tar'
Binary files test/automated/data/package/multi-file-0.2.3.tar	2013-06-27 09:26:54 +0000 and test/automated/data/package/multi-file-0.2.3.tar	2013-08-06 22:11:14 +0000 differ

=== modified file 'test/automated/data/package/simple-single-1.3.el'
--- test/automated/data/package/simple-single-1.3.el	2013-06-27 09:26:54 +0000
+++ test/automated/data/package/simple-single-1.3.el	2013-08-07 08:36:44 +0000
@@ -3,6 +3,7 @@
 ;; Author: J. R. Hacker <[email-masked]>
 ;; Version: 1.3
 ;; Keywords: frobnicate
+;; URL: http://doodles.au
 
 ;;; Commentary:

=== modified file 'test/automated/package-test.el'
--- test/automated/package-test.el	2013-07-11 16:01:26 +0000
+++ test/automated/package-test.el	2013-08-07 09:44:09 +0000
@@ -47,16 +47,10 @@
   (package-desc-create :name 'simple-single
                        :version '(1 3)
                        :summary "A single-file package with no dependencies"
-                       :kind 'single)
+                       :kind 'single
+                       :extras '((:homepage . "http://doodles.au")))
   "Expected `package-desc' parsed from simple-single-1.3.el.")
 
-(defvar simple-single-desc-1-4
-  (package-desc-create :name 'simple-single
-                       :version '(1 4)
-                       :summary "A single-file package with no dependencies"
-                       :kind 'single)
-  "Expected `package-desc' parsed from simple-single-1.4.el.")
-
 (defvar simple-depend-desc
   (package-desc-create :name 'simple-depend
                        :version '(1 0)
@@ -69,7 +63,8 @@
   (package-desc-create :name 'multi-file
                        :version '(0 2 3)
                        :summary "Example of a multi-file tar package"
-                       :kind 'tar)
+                       :kind 'tar
+                       :extras '((:homepage . "http://puddles.li")))
   "Expected `package-desc' from \"multi-file-0.2.3.tar\".")
 
 (defvar new-pkg-desc
@@ -100,7 +95,7 @@
           (package-user-dir package-test-user-dir)
           (package-archives `(("gnu" . ,package-test-data-dir)))
           (old-yes-no-defn (symbol-function 'yes-or-no-p))
-          (old-pwd default-directory)
+          (default-directory package-test-file-dir)
           package--initialized
           package-alist
           ,@(if update-news
@@ -131,8 +126,7 @@
        (when (and (boundp 'package-test-archive-upload-base)
                   (file-directory-p package-test-archive-upload-base))
          (delete-directory package-test-archive-upload-base t))
-       (setf (symbol-function 'yes-or-no-p) old-yes-no-defn)
-       (cd old-pwd))))
+       (setf (symbol-function 'yes-or-no-p) old-yes-no-defn))))
 
 (defmacro with-fake-help-buffer (&rest body)
   "Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer."
@@ -232,7 +226,9 @@
         (should (string= (buffer-string)
                          (concat "(define-package \"simple-single\" \"1.3\" "
                                  "\"A single-file package "
-                                 "with no dependencies\" 'nil)\n"))))
+                                 "with no dependencies\" 'nil "
+                                 ":homepage \"http://doodles.au\""
+                                 ")\n"))))
       (should (file-exists-p autoloads-file))
       (should-not (get-file-buffer autoloads-file)))))
 
@@ -357,23 +353,12 @@
      (should (search-forward "Version: 1.3" nil t))
      (should (search-forward "Summary: A single-file package with no dependencies"
                              nil t))
+     (should (search-forward "Homepage: http://doodles.au" nil t))
      ;; No description, though. Because at this point we don't know
      ;; what archive the package originated from, and we don't have
      ;; its readme file saved.
      )))
 
-(ert-deftest package-test-describe-not-installed-package ()
-  "Test displaying of the readme for not-installed package."
-
-  (with-package-test ()
-    (package-initialize)
-    (package-refresh-contents)
-    (with-fake-help-buffer
-     (describe-package 'simple-single)
-     (goto-char (point-min))
-     (should (search-forward "This package provides a minor mode to frobnicate"
-                             nil t)))))
-
 (ert-deftest package-test-describe-non-installed-package ()
   "Test displaying of the readme for non-installed package."
 
@@ -383,6 +368,7 @@
     (with-fake-help-buffer
      (describe-package 'simple-single)
      (goto-char (point-min))
+     (should (search-forward "Homepage: http://doodles.au" nil t))
      (should (search-forward "This package provides a minor mode to frobnicate"
                              nil t)))))
 
@@ -395,6 +381,7 @@
     (with-fake-help-buffer
      (describe-package 'multi-file)
      (goto-char (point-min))
+     (should (search-forward "Homepage: http://puddles.li" nil t))
      (should (search-forward "This is a bare-bones readme file for the multi-file"
                              nil t)))))

=== modified file 'test/automated/package-x-test.el'
--- test/automated/package-x-test.el	2013-07-09 07:11:50 +0000
+++ test/automated/package-x-test.el	2013-08-07 08:34:21 +0000
@@ -48,14 +48,16 @@
   (cons 'simple-single
         (package-make-ac-desc '(1 3) nil
                               "A single-file package with no dependencies"
-                              'single))
+                              'single
+                              '((:homepage . "http://doodles.au"))))
   "Expected contents of the archive entry from the \"simple-single\" package.")
 
 (defvar package-x-test--single-archive-entry-1-4
   (cons 'simple-single
         (package-make-ac-desc '(1 4) nil
                               "A single-file package with no dependencies"
-                              'single))
+                              'single
+                              nil))
   "Expected contents of the archive entry from the updated \"simple-single\" package.")
 
 (ert-deftest package-x-test-upload-buffer ()