X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fpackage-get.el;h=954d099bcc29d872e5eddeeb7a2dd601e70cb139;hb=b5f26301ee1ad7dbc9ad1c22e5b8564b5161d9ad;hp=023fe9189a23925e10e3f1b94ee0fe34c19472c4;hpb=b267e52aa03bee2c488c8a78824d96cf2d9a6ccc;p=chise%2Fxemacs-chise.git diff --git a/lisp/package-get.el b/lisp/package-get.el index 023fe91..954d099 100644 --- a/lisp/package-get.el +++ b/lisp/package-get.el @@ -3,6 +3,8 @@ ;; Copyright (C) 1998 by Pete Ware ;; Author: Pete Ware +;; Heavy-Modifications: Greg Klanderman +;; Jan Vroonhof ;; Keywords: internal ;; This file is part of XEmacs. @@ -29,6 +31,9 @@ ;; package-get - ;; Retrieve a package and any other required packages from an archive ;; +;; +;; Note (JV): Most of this no longer applies! +;; ;; The idea: ;; A new XEmacs lisp-only release is generated with the following steps: ;; 1. The maintainer runs some yet to be written program that @@ -63,7 +68,7 @@ ;; vm - a mail reader ;; [] Always install ;; [] Needs updating -;; [] Required by other [packages] +;; [] Required by other [packages] ;; ;; Where `[]' indicates a toggle box ;; @@ -74,7 +79,7 @@ ;; - "Required by other" means some other packages are going to force ;; this to be installed. Clicking on [packages] gives a list ;; of packages that require this. -;; +;; ;; The `package-get-base' should be installed in a file in ;; `data-directory'. The `package-get-here' should be installed in ;; site-lisp. Both are then read at run time. @@ -107,7 +112,8 @@ "Automatic Package Fetcher and Installer." :prefix "package-get" :group 'package-tools) - + +;;;###autoload (defvar package-get-base nil "List of packages that are installed at this site. For each element in the alist, car is the package name and the cdr is @@ -160,39 +166,156 @@ one version of a package available.") :type 'directory :group 'package-get) -;; JV Any Custom expert know to get "Host" and "Dir" for the remote option -(defcustom package-get-remote - '(("ftp.xemacs.org" "/pub/xemacs/packages")) +(define-widget 'host-name 'string + "A Host name." + :tag "Host") + +(defcustom package-get-remote nil "*List of remote sites to contact for downloading packages. List format is '(site-name directory-on-site). Each site is tried in order until the package is found. As a special case, `site-name' can be `nil', in which case `directory-on-site' is treated as a local directory." :tag "Package repository" :type '(repeat (choice (list :tag "Local" (const :tag "Local" nil) directory ) - (list :tag "Remote" string string) )) + (list :tag "Remote" host-name directory) )) + :group 'package-get) + +;;;###autoload +(defcustom package-get-download-sites + '( + ;; North America + ("Pre-Releases" "ftp.xemacs.org" "pub/xemacs/beta/experimental/packages") + ("xemacs.org" "ftp.xemacs.org" "pub/xemacs/packages") + ("crc.ca (Canada)" "ftp.crc.ca" "pub/packages/editors/xemacs/packages") + ("ualberta.ca (Canada)" "sunsite.ualberta.ca" "pub/Mirror/xemacs/packages") + ("uiuc.edu (United States)" "uiarchive.uiuc.edu" "pub/packages/xemacs/packages") + ("unc.edu (United States)" "metalab.unc.edu" "pub/packages/editors/xemacs/packages") + ("utk.edu (United States)" "ftp.sunsite.utk.edu" "pub/xemacs/packages") + + ;; South America + ("unicamp.br (Brazil)" "ftp.unicamp.br" "pub/xemacs/packages") + + ;; Europe + ("tuwien.ac.at (Austria)" "gd.tuwien.ac.at" "editors/xemacs/packages") + ("auc.dk (Denmark)" "sunsite.auc.dk" "pub/emacs/xemacs/packages") + ("doc.ic.ac.uk (England)" "sunsite.doc.ic.ac.uk" "packages/xemacs/packages") + ("funet.fi (Finland)" "ftp.funet.fi" "pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/packages") + ("cenatls.cena.dgac.fr (France)" "ftp.cenatls.cena.dgac.fr" "Emacs/xemacs/packages") + ("pasteur.fr (France)" "ftp.pasteur.fr" "pub/computing/xemacs/packages") + ("tu-darmstadt.de (Germany)" "ftp.tu-darmstadt.de" "pub/editors/xemacs/packages") + ("kfki.hu (Hungary)" "ftp.kfki.hu" "pub/packages/xemacs/packages") + ("eunet.ie (Ireland)" "ftp.eunet.ie" "mirrors/ftp.xemacs.org/pub/xemacs/packages") + ("uniroma2.it (Italy)" "ftp.uniroma2.it" "unix/misc/dist/XEMACS/packages") + ("uio.no (Norway)" "sunsite.uio.no" "pub/xemacs/packages") + ("icm.edu.pl (Poland)" "ftp.icm.edu.pl" "pub/unix/editors/xemacs/packages") + ("srcc.msu.su (Russia)" "ftp.srcc.msu.su" "mirror/ftp.xemacs.org/packages") + ("sunet.se (Sweden)" "ftp.sunet.se" "pub/gnu/xemacs/packages") + ("cnlab-switch.ch (Switzerland)" "sunsite.cnlab-switch.ch" "mirror/xemacs/packages") + + ;; Asia + ("aist.go.jp (Japan)" "ring.aist.go.jp" "pub/text/xemacs/packages") + ("asahi-net.or.jp (Japan)" "ring.asahi-net.or.jp" "pub/text/xemacs/packages") + ("dti.ad.jp (Japan)" "ftp.dti.ad.jp" "pub/unix/editor/xemacs/packages") + ("jaist.ac.jp (Japan)" "ftp.jaist.ac.jp" "pub/GNU/xemacs/packages") + ("nucba.ac.jp (Japan)" "mirror.nucba.ac.jp" "mirror/xemacs/packages") + ("sut.ac.jp (Japan)" "sunsite.sut.ac.jp" "pub/archives/packages/xemacs/packages") + ("tsukuba.ac.jp (Japan)" "ftp.netlab.is.tsukuba.ac.jp" "pub/GNU/xemacs/packages") + ("kreonet.re.kr (Korea)" "ftp.kreonet.re.kr" "pub/tools/emacs/xemacs/packages") + ("nctu.edu.tw (Taiwan)" "coda.nctu.edu.tw" "Editors/xemacs/packages") + + ;; Africa + ("sun.ac.za (South Africa)" "ftp.sun.ac.za" "xemacs/packages") + + ;; Middle East + ("isu.net.sa (Saudi Arabia)" "ftp.isu.net.sa" "pub/mirrors/ftp.xemacs.org/packages") + + ;; Australia + ("aarnet.edu.au (Australia)" "mirror.aarnet.edu.au" "pub/xemacs/packages") + ) + "*List of remote sites available for downloading packages. +List format is '(site-description site-name directory-on-site). +SITE-DESCRIPTION is a textual description of the site. SITE-NAME +is the internet address of the download site. DIRECTORY-ON-SITE +is the directory on the site in which packages may be found. +This variable is used to initialize `package-get-remote', the +variable actually used to specify package download sites." + :tag "Package download sites" + :type '(repeat (list (string :tag "Name") host-name directory)) :group 'package-get) -(defcustom package-get-remove-copy nil - "*After copying and installing a package, if this is T, then remove the +(defcustom package-get-remove-copy t + "*After copying and installing a package, if this is t, then remove the copy. Otherwise, keep it around." :type 'boolean :group 'package-get) -(defcustom package-get-base-filename - "/ftp.xemacs.org:/pub/xemacs/packages/package-index.LATEST" - "*Name of the default package database file, usually on ftp.xemacs.org." +;; #### it may make sense for this to be a list of names. +;; #### also, should we rename "*base*" to "*index*" or "*db*"? +;; "base" is a pretty poor name. +(defcustom package-get-base-filename "package-index.LATEST.pgp" + "*Name of the default package-get database file. +This may either be a relative path, in which case it is interpreted +with respect to `package-get-remote', or an absolute path." :type 'file :group 'package-get) +(defvar package-get-user-index-filename + (paths-construct-path (list user-init-directory package-get-base-filename)) + "Name for the user-specific location of the package-get database file.") + +(defcustom package-get-always-update nil + "*If Non-nil always make sure we are using the latest package index (base). +Otherwise respect the `force-current' argument of `package-get-require-base'." + :type 'boolean + :group 'package-get) + +(defcustom package-get-require-signed-base-updates nil + "*If set to a non-nil value, require explicit user confirmation for updates +to the package-get database which cannot have their signature verified via PGP. +When nil, updates which are not PGP signed are allowed without confirmation." + :type 'boolean + :group 'package-get) + +(defvar package-get-was-current nil + "Non-nil we did our best to fetch a current database.") + + +;Shouldn't this be in package-ui? +;;;###autoload +(defun package-get-download-menu () + "Build the `Add Download Site' menu." + (mapcar (lambda (site) + (vector (car site) + `(if (member (quote ,(cdr site)) + package-get-remote) + (setq package-get-remote + (delete (quote ,(cdr site)) + package-get-remote)) + (package-ui-add-site (quote ,(cdr site)))) + :style 'toggle + :selected `(member (quote ,(cdr site)) + package-get-remote))) + package-get-download-sites)) + ;;;###autoload -(defun package-get-require-base () - "Require that a package-get database has been loaded." - (when (or (not (boundp 'package-get-base)) - (not package-get-base)) - (package-get-update-base)) - (when (or (not (boundp 'package-get-base)) - (not package-get-base)) - (error "Package-get database not loaded"))) +(defun package-get-require-base (&optional force-current) + "Require that a package-get database has been loaded. +If the optional FORCE-CURRENT argument or the value of +`package-get-always-update' is Non-nil, try to update the database +from a location in `package-get-remote'. Otherwise a local copy is used +if available and remote access is never done. + +Please use FORCE-CURRENT only when the user is explictly dealing with packages +and remote access is likely in the near future." + (setq force-current (or force-current package-get-always-update)) + (unless (and (boundp 'package-get-base) + package-get-base + (or (not force-current) package-get-was-current)) + (package-get-update-base nil force-current)) + (if (or (not (boundp 'package-get-base)) + (not package-get-base)) + (error "Package-get database not loaded") + (setq package-get-was-current force-current))) (defconst package-get-pgp-signed-begin-line "^-----BEGIN PGP SIGNED MESSAGE-----" "Text for start of PGP signed messages.") @@ -204,21 +327,71 @@ copy. Otherwise, keep it around." ;;;###autoload (defun package-get-update-base-entry (entry) "Update an entry in `package-get-base'." - (let ((existing (assoc (car entry) package-get-base))) + (let ((existing (assq (car entry) package-get-base))) (if existing (setcdr existing (cdr entry)) - (setq package-get-base (cons entry package-get-base))))) + (setq package-get-base (cons entry package-get-base)) + (package-get-custom-add-entry (car entry) (car (cdr entry)))))) + +(defun package-get-locate-file (file &optional nil-if-not-found no-remote) + "Locate an existing FILE with respect to `package-get-remote'. +If FILE is an absolute path or is not found, simply return FILE. +If optional argument NIL-IF-NOT-FOUND is non-nil, return nil +if FILE can not be located. +If NO-REMOTE is non-nil never search remote locations." + (if (file-name-absolute-p file) + file + (let ((entries package-get-remote) + (expanded nil)) + (while entries + (unless (and no-remote (caar entries)) + (let ((expn (package-get-remote-filename (car entries) file))) + (if (and expn (file-exists-p expn)) + (setq entries nil + expanded expn)))) + (setq entries (cdr entries))) + (or expanded + (and (not nil-if-not-found) + file))))) + +(defun package-get-locate-index-file (no-remote) + "Locate the package-get index file. Do not return remote paths if NO-REMOTE +is non-nil." + (or (package-get-locate-file package-get-base-filename t no-remote) + (if (file-exists-p package-get-user-index-filename) + package-get-user-index-filename))) + +(defun package-get-maybe-save-index (filename) + "Offer to save the current buffer as the local package index file, +if different." + (let ((location (package-get-locate-index-file t))) + (unless (and filename (equal filename location)) + (unless (and location + (equal (md5 (current-buffer)) + (with-temp-buffer + (insert-file-contents-literally location) + (md5 (current-buffer))))) + (unless (and location (file-writable-p location)) + (setq location package-get-user-index-filename)) + (when (y-or-n-p (concat "Update package index in " location "? ")) + (let ((coding-system-for-write 'binary)) + (write-file location))))))) + ;;;###autoload -(defun package-get-update-base (&optional db-file) - "Update the package-get database file with entries from DB-FILE." - (interactive (list - (read-file-name "Load package-get database: " - (file-name-directory package-get-base-filename) - package-get-base-filename - t - (file-name-nondirectory package-get-base-filename)))) - (setq db-file (expand-file-name (or db-file package-get-base-filename))) +(defun package-get-update-base (&optional db-file force-current) + "Update the package-get database file with entries from DB-FILE. +Unless FORCE-CURRENT is non-nil never try to update the database." + (interactive + (let ((dflt (package-get-locate-index-file nil))) + (list (read-file-name "Load package-get database: " + (file-name-directory dflt) + dflt + t + (file-name-nondirectory dflt))))) + (setq db-file (expand-file-name (or db-file + (package-get-locate-index-file + (not force-current))))) (if (not (file-exists-p db-file)) (error "Package-get database file `%s' does not exist" db-file)) (if (not (file-readable-p db-file)) @@ -228,8 +401,10 @@ copy. Otherwise, keep it around." (save-excursion (set-buffer buf) (erase-buffer buf) - (insert-file-contents-internal db-file) - (package-get-update-base-from-buffer buf)) + (insert-file-contents-literally db-file) + (package-get-update-base-from-buffer buf) + (if (file-remote-p db-file) + (package-get-maybe-save-index db-file))) (kill-buffer buf)))) ;;;###autoload @@ -253,7 +428,8 @@ used interactively, for example from a mail or news buffer." (when (re-search-forward package-get-pgp-signature-end-line nil t) (setq end (point))) (if (not (and content-beg content-end beg end)) - (or (yes-or-no-p "Package-get entries not PGP signed, continue? ") + (or (not package-get-require-signed-base-updates) + (yes-or-no-p "Package-get entries not PGP signed, continue? ") (error "Package-get database not updated"))) (if (and content-beg content-end beg end) (if (not (condition-case nil @@ -261,7 +437,8 @@ used interactively, for example from a mail or news buffer." (load-library "mc-pgp") (fboundp 'mc-pgp-verify-region)) (error nil))) - (or (yes-or-no-p + (or (not package-get-require-signed-base-updates) + (yes-or-no-p "No mailcrypt; can't verify package-get DB signature, continue? ") (error "Package-get database not updated")))) (if (and beg end @@ -271,18 +448,21 @@ used interactively, for example from a mail or news buffer." (mc-pgp-verify-region beg end) (file-error (and (string-match "No such file" (nth 2 err)) - (yes-or-no-p - "Can't find PGP, continue without package-get DB verification? "))) + (or (not package-get-require-signed-base-updates) + (yes-or-no-p + (concat "Can't find PGP, continue without " + "package-get DB verification? "))))) (t nil))))) (error "Package-get PGP signature failed to verify")) + ;; ToDo: We should call package-get-maybe-save-index on the region (package-get-update-base-entries content-beg content-end) (message "Updated package-get database")))) -(defun package-get-update-base-entries (beg end) +(defun package-get-update-base-entries (start end) "Update the package-get database with the entries found between -BEG and END in the current buffer." +START and END in the current buffer." (save-excursion - (goto-char beg) + (goto-char start) (if (not (re-search-forward "^(package-get-update-base-entry" nil t)) (error "Buffer does not contain package-get database entries")) (beginning-of-line) @@ -299,25 +479,57 @@ BEG and END in the current buffer." (setq count (1+ count)))) (message "Got %d package-get database entries" count)))) +;;;###autoload +(defun package-get-save-base (file) + "Write the package-get database to FILE. + +Note: This database will be unsigned of course." + (interactive "FSave package-get database to: ") + (package-get-require-base t) + (let ((buf (get-buffer-create "*package database*"))) + (unwind-protect + (save-excursion + (set-buffer buf) + (erase-buffer buf) + (goto-char (point-min)) + (let ((entries package-get-base) entry plist) + (insert ";; Package Index file -- Do not edit manually.\n") + (insert ";;;@@@\n") + (while entries + (setq entry (car entries)) + (setq plist (car (cdr entry))) + (insert "(package-get-update-base-entry (quote\n") + (insert (format "(%s\n" (symbol-name (car entry)))) + (while plist + (insert (format " %s%s %S\n" + (if (eq plist (car (cdr entry))) "(" " ") + (symbol-name (car plist)) + (car (cdr plist)))) + (setq plist (cdr (cdr plist)))) + (insert "))\n))\n;;;@@@\n") + (setq entries (cdr entries)))) + (insert ";; Package Index file ends here\n") + (write-region (point-min) (point-max) file)) + (kill-buffer buf)))) + (defun package-get-interactive-package-query (get-version package-symbol) "Perform interactive querying for package and optional version. Query for a version if GET-VERSION is non-nil. Return package name as a symbol instead of a string if PACKAGE-SYMBOL is non-nil. The return value is suitable for direct passing to `interactive'." - (package-get-require-base) - (let ( (table (mapcar '(lambda (item) - (let ( (name (symbol-name (car item))) ) - (cons name name) - )) - package-get-base)) - package package-symbol default-version version) + (package-get-require-base t) + (let ((table (mapcar #'(lambda (item) + (let ((name (symbol-name (car item)))) + (cons name name))) + package-get-base)) + package package-symbol default-version version) (save-window-excursion (setq package (completing-read "Package: " table nil t)) (setq package-symbol (intern package)) (if get-version (progn - (setq default-version - (package-get-info-prop + (setq default-version + (package-get-info-prop (package-get-info-version (package-get-info-find-package package-get-base package-symbol) nil) @@ -332,8 +544,7 @@ The return value is suitable for direct passing to `interactive'." ) (if package-symbol (list package-symbol) - (list package))) - ))) + (list package)))))) ;;;###autoload (defun package-get-delete-package (package &optional pkg-topdir) @@ -347,7 +558,7 @@ This is just an interactive wrapper for `package-admin-delete-binary-package'." (defun package-get-update-all () "Fetch and install the latest versions of all currently installed packages." (interactive) - (package-get-require-base) + (package-get-require-base t) ;; Load a fresh copy (catch 'exit (mapcar (lambda (pkg) @@ -392,7 +603,7 @@ Returns nil upon error." (while this-requires (if (not (member (car this-requires) fetched-packages)) (let* ((reqd-package (package-get-package-provider - (car this-requires))) + (car this-requires) t)) (reqd-version (cadr reqd-package)) (reqd-name (car reqd-package))) (if (null reqd-name) @@ -415,7 +626,7 @@ Returns nil upon error." Uses `package-get-base' to determine just what is required and what package provides that functionality. Returns the list of packages required by PACKAGES." - (package-get-require-base) + (package-get-require-base t) (let ((orig-packages packages) dependencies provided) (while packages @@ -429,7 +640,6 @@ required by PACKAGES." (mapcar #'(lambda (reqd) (let* ((reqd-package (package-get-package-provider reqd)) - (reqd-version (cadr reqd-package)) (reqd-name (car reqd-package))) (if (null reqd-name) (error "Unable to find a provider for %s" reqd)) @@ -496,7 +706,7 @@ package is already installed. Valid values for CONFLICT are: INSTALL-DIR, if non-nil, specifies the package directory where fetched packages should be installed. -The value of `package-get-base' is used to determine what files should +The value of `package-get-base' is used to determine what files should be retrieved. The value of `package-get-remote' is used to determine where a package should be retrieved from. The sites are tried in order so one is better off listing easily reached sites first. @@ -509,10 +719,13 @@ Returns `t' upon success, the symbol `error' if the package was successfully installed but errors occurred during initialization, or `nil' upon error." (interactive (package-get-interactive-package-query nil t)) + (catch 'skip-update (let* ((this-package (package-get-info-version (package-get-info-find-package package-get-base package) version)) + (latest (package-get-info-prop this-package 'version)) + (installed (package-get-key package :version)) (this-requires (package-get-info-prop this-package 'requires)) (found nil) (search-dirs package-get-remote) @@ -520,8 +733,10 @@ successfully installed but errors occurred during initialization, or (package-status t) filenames full-package-filename) (if (null this-package) - (error "Couldn't find package %s with version %s" - package version)) + (if package-get-remote + (error "Couldn't find package %s with version %s" + package version) + (error "No download sites or local package locations specified."))) (if (null base-filename) (error "No filename associated with package %s, version %s" package version)) @@ -529,6 +744,22 @@ successfully installed but errors occurred during initialization, or (package-admin-get-install-dir package install-dir (or (eq package 'mule-base) (memq 'mule-base this-requires)))) + ;; If they asked for the latest using version=nil, don't get an older + ;; version than we already have. + (if installed + (if (> (if (stringp installed) + (string-to-number installed) + installed) + (if (stringp latest) + (string-to-number latest) + latest)) + (if (not (null version)) + (warn "Installing %s package version %s, you had a newer version %s" + package latest installed) + (warn "Skipping %s package, you have a newer version %s" + package installed) + (throw 'skip-update t)))) + ;; Contrive a list of possible package filenames. ;; Ugly. Is there a better way to do this? (setq filenames (cons base-filename nil)) @@ -537,7 +768,7 @@ successfully installed but errors occurred during initialization, or (list (concat (match-string 1 base-filename) ".tgz"))))) - (setq version (package-get-info-prop this-package 'version)) + (setq version latest) (unless (and (eq conflict 'never) (package-get-installedp package version)) ;; Find the package from the search list in package-get-remote @@ -583,7 +814,7 @@ successfully installed but errors occurred during initialization, or current-dir-entry current-filename)) ;; Get it (setq full-package-filename dest-filename) - (message "Retrieving package `%s' ..." + (message "Retrieving package `%s' ..." current-filename) (sit-for 0) (copy-file (package-get-remote-filename current-dir-entry @@ -606,14 +837,15 @@ successfully installed but errors occurred during initialization, or (if (or (not full-package-filename) (not (file-exists-p full-package-filename))) - (error "Unable to find file %s" base-filename)) + (if package-get-remote + (error "Unable to find file %s" base-filename) + (error + "No download sites or local package locations specified."))) ;; Validate the md5 checksum ;; Doing it with XEmacs removes the need for an external md5 program (message "Validating checksum for `%s'..." package) (sit-for 0) (with-temp-buffer - ;; What ever happened to i-f-c-literally - (let (file-name-handler-alist) - (insert-file-contents-internal full-package-filename)) + (insert-file-contents-literally full-package-filename) (if (not (string= (md5 (current-buffer)) (package-get-info-prop this-package 'md5sum))) @@ -657,7 +889,7 @@ successfully installed but errors occurred during initialization, or (if (and found package-get-remove-copy) (delete-file full-package-filename)) package-status - )) + ))) (defun package-get-info-find-package (which name) "Look in WHICH for the package called NAME and return all the info @@ -666,7 +898,7 @@ returned. To access fields returned from this, use `package-get-info-version' to return information about particular a -version. Use `package-get-info-find-prop' to find particular property +version. Use `package-get-info-find-prop' to find particular property from a version returned by `package-get-info-version'." (interactive "xPackage list: \nsPackage Name: ") (if which @@ -678,7 +910,7 @@ from a version returned by `package-get-info-version'." (defun package-get-info-version (package version) "In PACKAGE, return the plist associated with a particular VERSION of the package. PACKAGE is typically as returned by - `package-get-info-find-package'. If VERSION is nil, then return the + `package-get-info-find-package'. If VERSION is nil, then return the first (aka most recent) version. Use `package-get-info-find-prop' to retrieve a particular property from the value returned by this." (interactive (package-get-interactive-package-query t t)) @@ -734,13 +966,19 @@ It first checks if FILENAME already is a remote filename. If it is not, then it uses the (car search) as the remote site-name and the (cadr search) as the remote-directory and concatenates filename. In other words - site-name:remote-directory/filename + site-name:remote-directory/filename. + +If (car search) is nil, (cadr search is interpreted as a local directory). " - (if (efs-ftp-path filename) + (if (file-remote-p filename) filename (let ((dir (cadr search))) - (concat "/" - (car search) ":" + (concat (when (car search) + (concat + (if (string-match "@" (car search)) + "/" + "/anonymous@") + (car search) ":")) (if (string-match "/$" dir) dir (concat dir "/")) @@ -749,7 +987,7 @@ words (defun package-get-installedp (package version) "Determine if PACKAGE with VERSION has already been installed. -I'm not sure if I want to do this by searching directories or checking +I'm not sure if I want to do this by searching directories or checking some built in variables. For now, use packages-package-list." ;; Use packages-package-list which contains name and version (equal (plist-get @@ -758,13 +996,16 @@ some built in variables. For now, use packages-package-list." (if (floatp version) version (string-to-number version)))) ;;;###autoload -(defun package-get-package-provider (sym) +(defun package-get-package-provider (sym &optional force-current) "Search for a package that provides SYM and return the name and version. Searches in `package-get-base' for SYM. If SYM is a - consp, then it must match a corresponding (provide (SYM VERSION)) from - the package." + consp, then it must match a corresponding (provide (SYM VERSION)) from + the package. + +If FORCE-CURRENT is non-nil make sure the database is up to date. This might +lead to Emacs accessing remote sites." (interactive "SSymbol: ") - (package-get-require-base) + (package-get-require-base force-current) (let ((packages package-get-base) (done nil) (found nil)) @@ -774,14 +1015,20 @@ some built in variables. For now, use packages-package-list." (while (and (not done) this-package) (if (or (eq this-name sym) (eq (cons this-name - (package-get-info-prop (car this-package) 'version)) + (package-get-info-prop (car this-package) 'version)) sym) - (member sym (package-get-info-prop (car this-package) 'provides))) + (member sym + (package-get-info-prop (car this-package) 'provides))) (progn (setq done t) - (setq found (list (caar packages) - (package-get-info-prop (car this-package) 'version)))) + (setq found + (list (caar packages) + (package-get-info-prop (car this-package) 'version)))) (setq this-package (cdr this-package))))) (setq packages (cdr packages))) + (when (interactive-p) + (if found + (message "%S" found) + (message "No appropriate package found"))) found)) ;; @@ -796,101 +1043,43 @@ some built in variables. For now, use packages-package-list." (defun package-get-custom () "Fetch and install the latest versions of all customized packages." (interactive) - (package-get-require-base) - ;; Load a fresh copy - (load "package-get-custom.el") + (package-get-require-base t) (mapcar (lambda (pkg) (if (eval (intern (concat (symbol-name (car pkg)) "-package"))) - (package-get-all (car pkg) nil)) + (package-get (car pkg) nil)) t) - package-get-base)) + package-get-base) + (package-net-update-installed-db)) (defun package-get-ever-installed-p (pkg &optional notused) (string-match "-package$" (symbol-name pkg)) - (custom-initialize-set - pkg - (if (package-get-info-find-package - packages-package-list + (custom-initialize-set + pkg + (if (package-get-info-find-package + packages-package-list (intern (substring (symbol-name pkg) 0 (match-beginning 0)))) t))) -(defun package-get-file-installed-p (file &optional paths) - "Return absolute-path of FILE if FILE exists in PATHS. -If PATHS is omitted, `load-path' is used." - (if (null paths) - (setq paths load-path) - ) - (catch 'tag - (let (path) - (while paths - (setq path (expand-file-name file (car paths))) - (if (file-exists-p path) - (throw 'tag path) - ) - (setq paths (cdr paths)) - )))) +(defvar package-get-custom-groups nil + "List of package-get-custom groups") + +(defun package-get-custom-add-entry (package props) + (let* ((category (plist-get props 'category)) + (group (intern (concat category "-packages"))) + (custom-var (intern (concat (symbol-name package) "-package"))) + (description (plist-get props 'description))) + (when (not (memq group package-get-custom-groups)) + (setq package-get-custom-groups (cons group + package-get-custom-groups)) + (eval `(defgroup ,group nil + ,(concat category " package group") + :group 'packages))) + (eval `(defcustom ,custom-var nil + ,description + :group ',group + :initialize 'package-get-ever-installed-p + :type 'boolean)))) -(defun package-get-create-custom () - "Creates a package customization file package-get-custom.el. -Entries in the customization file are retrieved from package-get-base.el." - (interactive) - ;; Load a fresh copy - (let ((custom-buffer (find-file-noselect - (or (package-get-file-installed-p - "package-get-custom.el") - (expand-file-name - "package-get-custom.el" - (file-name-directory - (package-get-file-installed-p - "package-get-base.el")) - )))) - (pkg-groups nil)) - - ;; clear existing stuff - (delete-region (point-min custom-buffer) - (point-max custom-buffer) custom-buffer) - (insert-string "(require 'package-get)\n" custom-buffer) - (mapcar (lambda (pkg) - (let ((category (plist-get (car (cdr pkg)) 'category))) - (or (memq (intern category) pkg-groups) - (progn - (setq pkg-groups (cons (intern category) pkg-groups)) - (insert-string - (concat "(defgroup " category "-packages nil\n" - " \"" category " package group\"\n" - " :group 'packages)\n\n") custom-buffer))) - - (insert-string - (concat "(defcustom " (symbol-name (car pkg)) - "-package nil \n" - " \"" (plist-get (car (cdr pkg)) 'description) "\"\n" - " :group '" category "-packages\n" - " :initialize 'package-get-ever-installed-p\n" - " :type 'boolean)\n\n") custom-buffer))) - package-get-base) custom-buffer) - ) - -;; need this first to avoid infinite dependency loops (provide 'package-get) - -;; potentially update the custom dependencies every time we load this -(when nil ;; #### disable for now... -gk -(unless noninteractive -(let ((custom-file (package-get-file-installed-p "package-get-custom.el")) - (package-file (package-get-file-installed-p "package-get-base.el"))) - ;; update custom file if it doesn't exist - (if (or (not custom-file) - (and (< (car (nth 5 (file-attributes custom-file))) - (car (nth 5 (file-attributes package-file)))) - (< (car (nth 5 (file-attributes custom-file))) - (car (nth 5 (file-attributes package-file)))))) - (save-excursion - (message "generating package customizations...") - (set-buffer (package-get-create-custom)) - (save-buffer) - (message "generating package customizations...done"))) - (load "package-get-custom.el"))) -) - ;;; package-get.el ends here