X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/3a12f2ed99734eff668f83f630c7108000e0b399..9a895795e862f8082d0ea00cb33f4ca36b7d8196:/lisp/emacs-lisp/package.el

diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 80b7670c1f..88fc950ee2 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -1,6 +1,6 @@
 ;;; package.el --- Simple package system for Emacs  -*- lexical-binding:t -*-
 
-;; Copyright (C) 2007-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2015 Free Software Foundation, Inc.
 
 ;; Author: Tom Tromey <tromey@redhat.com>
 ;;         Daniel Hackney <dan@haxney.org>
@@ -228,6 +228,23 @@ a package can run arbitrary code."
   :group 'package
   :version "24.1")
 
+(defcustom package-archive-priorities nil
+  "An alist of priorities for packages.
+
+Each element has the form (ARCHIVE-ID . PRIORITY).
+
+When installing packages, the package with the highest version
+number from the archive with the highest priority is
+selected. When higher versions are available from archives with
+lower priorities, the user has to select those manually.
+
+Archives not in this list have the priority 0."
+  :type '(alist :key-type (string :tag "Archive name")
+                :value-type (integer :tag "Priority (default is 0)"))
+  :risky t
+  :group 'package
+  :version "25.1")
+
 (defcustom package-pinned-packages nil
   "An alist of packages that are pinned to specific archives.
 This can be useful if you have multiple package archives enabled,
@@ -397,6 +414,7 @@ Slots:
   (pcase (package-desc-kind pkg-desc)
     (`single ".el")
     (`tar ".tar")
+    (`dir "")
     (kind (error "Unknown package kind: %s" kind))))
 
 (defun package-desc--keywords (pkg-desc)
@@ -784,6 +802,20 @@ untar into a directory named DIR; otherwise, signal an error."
          (dirname (package-desc-full-name pkg-desc))
 	 (pkg-dir (expand-file-name dirname package-user-dir)))
     (pcase (package-desc-kind pkg-desc)
+      (`dir
+       (make-directory pkg-dir t)
+       (let ((file-list
+              (directory-files
+               default-directory 'full "\\`[^.].*\\.el\\'" 'nosort)))
+         (dolist (source-file file-list)
+           (let ((target-el-file
+                  (expand-file-name (file-name-nondirectory source-file) pkg-dir)))
+             (copy-file source-file target-el-file t)))
+         ;; Now that the files have been installed, this package is
+         ;; indistinguishable from a `tar' or a `single'. Let's make
+         ;; things simple by ensuring we're one of them.
+         (setf (package-desc-kind pkg-desc)
+               (if (> (length file-list) 1) 'tar 'single))))
       (`tar
        (make-directory package-user-dir t)
        ;; FIXME: should we delete PKG-DIR if it exists?
@@ -909,6 +941,9 @@ GnuPG keyring is located under \"gnupg\" in `package-user-dir'."
 
 (defun package-install-from-archive (pkg-desc)
   "Download and install a tar package."
+  ;; This won't happen, unless the archive is doing something wrong.
+  (when (eq (package-desc-kind pkg-desc) 'dir)
+    (error "Can't install directory package from archive"))
   (let* ((location (package-archive-base pkg-desc))
 	 (file (concat (package-desc-full-name pkg-desc)
 		       (package-desc-suffix pkg-desc)))
@@ -1114,23 +1149,34 @@ Also, add the originating archive to the `package-desc' structure."
                         ;; 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
-     ;; Skip entirely if pinned to another archive.
-     ((and pinned-to-archive
-           (not (equal (cdr pinned-to-archive) archive)))
-      nil)
-     ((not existing-packages)
-      (push (list name pkg-desc) package-archive-contents))
-     (t
-      (while
-          (if (and (cdr existing-packages)
-                   (version-list-<
-                    version (package-desc-version (cadr existing-packages))))
-              (setq existing-packages (cdr existing-packages))
-            (push pkg-desc (cdr existing-packages))
-            nil))))))
+    ;; Skip entirely if pinned to another archive.
+    (when (not (and pinned-to-archive
+                    (not (equal (cdr pinned-to-archive) archive))))
+      (setq package-archive-contents
+            (package--append-to-alist pkg-desc package-archive-contents)))))
+
+(defun package--append-to-alist (pkg-desc alist)
+  "Append an entry for PKG-DESC to the start of ALIST and return it.
+This entry takes the form (`package-desc-name' PKG-DESC).
+
+If ALIST already has an entry with this name, destructively add
+PKG-DESC to the cdr of this entry instead, sorted by version
+number."
+  (let* ((name (package-desc-name pkg-desc))
+         (priority-version (package-desc-priority-version pkg-desc))
+         (existing-packages (assq name alist)))
+    (if (not existing-packages)
+        (cons (list name pkg-desc)
+              alist)
+      (while (if (and (cdr existing-packages)
+                      (version-list-< priority-version
+                                      (package-desc-priority-version
+                                       (cadr existing-packages))))
+                 (setq existing-packages (cdr existing-packages))
+               (push pkg-desc (cdr existing-packages))
+               nil))
+      alist)))
 
 (defun package-download-transaction (packages)
   "Download and install all the packages in PACKAGES.
@@ -1252,30 +1298,74 @@ The return result is a `package-desc'."
     (unless tar-desc
       (error "No package descriptor file found"))
     (with-current-buffer (tar--extract tar-desc)
-      (goto-char (point-min))
       (unwind-protect
-          (let* ((pkg-def-parsed (read (current-buffer)))
-                 (pkg-desc
-                  (if (not (eq (car pkg-def-parsed) 'define-package))
-                      (error "Can't find define-package in %s"
-                             (tar-header-name tar-desc))
-                    (apply #'package-desc-from-define
-                           (append (cdr pkg-def-parsed))))))
-            (setf (package-desc-kind pkg-desc) 'tar)
-            pkg-desc)
+          (package--read-pkg-desc 'tar)
         (kill-buffer (current-buffer))))))
 
+(defun package-dir-info ()
+  "Find package information for a directory.
+The return result is a `package-desc'."
+  (cl-assert (derived-mode-p 'dired-mode))
+  (let* ((desc-file (package--description-file default-directory)))
+    (if (file-readable-p desc-file)
+        (with-temp-buffer
+          (insert-file-contents desc-file)
+          (package--read-pkg-desc 'dir))
+      (let ((files (directory-files default-directory t "\\.el\\'" t))
+            info)
+        (while files
+          (with-temp-buffer
+            (insert-file-contents (pop files))
+            ;; When we find the file with the data,
+            (when (setq info (ignore-errors (package-buffer-info)))
+              ;; stop looping,
+              (setq files nil)
+              ;; set the 'dir kind,
+              (setf (package-desc-kind info) 'dir))))
+        ;; and return the info.
+        info))))
+
+(defun package--read-pkg-desc (kind)
+  "Read a `define-package' form in current buffer.
+Return the pkg-desc, with desc-kind set to KIND."
+  (goto-char (point-min))
+  (unwind-protect
+      (let* ((pkg-def-parsed (read (current-buffer)))
+             (pkg-desc
+              (if (not (eq (car pkg-def-parsed) 'define-package))
+                  (error "Can't find define-package in %s"
+                         (tar-header-name tar-desc))
+                (apply #'package-desc-from-define
+                  (append (cdr pkg-def-parsed))))))
+        (setf (package-desc-kind pkg-desc) kind)
+        pkg-desc)))
+
 
 ;;;###autoload
 (defun package-install-from-buffer ()
   "Install a package from the current buffer.
-The current buffer is assumed to be a single .el or .tar file that follows the
-packaging guidelines; see info node `(elisp)Packaging'.
+The current buffer is assumed to be a single .el or .tar file or
+a directory.  These must follow the packaging guidelines (see
+info node `(elisp)Packaging').
+
+Specially, if current buffer is a directory, the -pkg.el
+description file is not mandatory, in which case the information
+is derived from the main .el file in the directory.
+
 Downloads and installs required packages as needed."
   (interactive)
-  (let ((pkg-desc (if (derived-mode-p 'tar-mode)
-                      (package-tar-file-info)
-                    (package-buffer-info))))
+  (let ((pkg-desc
+         (cond
+          ((derived-mode-p 'dired-mode)
+           ;; This is the only way a package-desc object with a `dir'
+           ;; desc-kind can be created.  Such packages can't be
+           ;; uploaded or installed from archives, they can only be
+           ;; installed from local buffers or directories.
+           (package-dir-info))
+          ((derived-mode-p 'tar-mode)
+           (package-tar-file-info))
+          (t
+           (package-buffer-info)))))
     ;; Download and install the dependencies.
     (let* ((requires (package-desc-reqs pkg-desc))
            (transaction (package-compute-transaction nil requires)))
@@ -1290,8 +1380,12 @@ Downloads and installs required packages as needed."
 The file can either be a tar file or an Emacs Lisp file."
   (interactive "fPackage file name: ")
   (with-temp-buffer
-    (insert-file-contents-literally file)
-    (when (string-match "\\.tar\\'" file) (tar-mode))
+    (if (file-directory-p file)
+        (progn
+          (setq default-directory file)
+          (dired-mode))
+      (insert-file-contents-literally file)
+      (when (string-match "\\.tar\\'" file) (tar-mode)))
     (package-install-from-buffer)))
 
 (defun package-delete (pkg-desc)
@@ -1319,6 +1413,25 @@ The file can either be a tar file or an Emacs Lisp file."
   "Return the archive containing the package NAME."
   (cdr (assoc (package-desc-archive desc) package-archives)))
 
+(defun package-archive-priority (archive)
+  "Return the priority of ARCHIVE.
+
+The archive priorities are specified in
+`package-archive-priorities'. If not given there, the priority
+defaults to 0."
+  (or (cdr (assoc archive package-archive-priorities))
+      0))
+
+(defun package-desc-priority-version (pkg-desc)
+  "Return the version PKG-DESC with the archive priority prepended.
+
+This allows for easy comparison of package versions from
+different archives if archive priorities are meant to be taken in
+consideration."
+  (cons (package-archive-priority
+         (package-desc-archive pkg-desc))
+        (package-desc-version pkg-desc)))
+
 (defun package--download-one-archive (archive file)
   "Retrieve an archive file FILE from ARCHIVE, and cache it.
 ARCHIVE should be a cons cell of the form (NAME . LOCATION),
@@ -1991,18 +2104,18 @@ If optional arg BUTTON is non-nil, describe its associated package."
       ;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC])
       (let ((pkg-desc (car entry))
 	    (status (aref (cadr entry) 2)))
-	(cond ((member status '("installed" "unsigned"))
-	       (push pkg-desc installed))
-	      ((member status '("available" "new"))
-	       (push (cons (package-desc-name pkg-desc) pkg-desc)
-                     available)))))
+        (cond ((member status '("installed" "unsigned"))
+               (push pkg-desc installed))
+              ((member status '("available" "new"))
+               (setq available (package--append-to-alist pkg-desc available))))))
     ;; Loop through list of installed packages, finding upgrades.
     (dolist (pkg-desc installed)
-      (let ((avail-pkg (assq (package-desc-name pkg-desc) available)))
-	(and avail-pkg
-	     (version-list-< (package-desc-version pkg-desc)
-                             (package-desc-version (cdr avail-pkg)))
-	     (push avail-pkg upgrades))))
+      (let* ((name (package-desc-name pkg-desc))
+             (avail-pkg (cadr (assq name available))))
+        (and avail-pkg
+             (version-list-< (package-desc-priority-version pkg-desc)
+                             (package-desc-priority-version avail-pkg))
+             (push (cons name avail-pkg) upgrades))))
     upgrades))
 
 (defun package-menu-mark-upgrades ()