cgit.sxemacs.org Git - sxemacs/blob - lisp/package-get.el

   1 ;;; package-get.el --- Retrieve SXEmacs package
   2
   3 ;; Copyright (C) 1998 by Pete Ware
   4 ;; Copyright (C) 2002 Ben Wing.
   5 ;; Copyright (C) 2003 - 2015 Steve Youngs
   6
   7 ;; Author: Pete Ware <ware@cis.ohio-state.edu>
   8 ;; Heavy-Modifications: Greg Klanderman <greg@alphatech.com>
   9 ;;                      Jan Vroonhof    <vroonhof@math.ethz.ch>
  10 ;;                      Steve Youngs    <steve@sxemacs.org>
  11 ;; Keywords: internal
  12
  13 ;; This file is part of SXEmacs.
  14
  15 ;; SXEmacs is free software: you can redistribute it and/or modify
  16 ;; it under the terms of the GNU General Public License as published by
  17 ;; the Free Software Foundation, either version 3 of the License, or
  18 ;; (at your option) any later version.
  19
  20 ;; SXEmacs is distributed in the hope that it will be useful,
  21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;; GNU General Public License for more details.
  24
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  27
  28 ;;; Synched up with: Not in FSF
  29
  30 ;;; Commentary:
  31
  32 ;; package-get -
  33 ;;      Retrieve a package and any other required packages from an archive
  34 ;;
  35 ;;
  36 ;; Note (JV): Most of this no longer applies!
  37 ;; Note (SY): Definitely no longer applies, but I'm leaving these
  38 ;;            comments here because there are some nifty ideas here.
  39 ;;
  40 ;; The idea:
  41 ;;      A new XEmacs lisp-only release is generated with the following steps:
  42 ;;      1. The maintainer runs some yet to be written program that
  43 ;;         generates all the dependency information.  This should
  44 ;;         determine all the require and provide statements and associate
  45 ;;         them with a package.
  46 ;;      2. All the packages are then bundled into their own tar balls
  47 ;;         (or whatever format)
  48 ;;      3. Maintainer automatically generates a new `package-get-base'
  49 ;;         data structure which contains information such as the
  50 ;;         package name, the file to be retrieved, an md5 checksum,
  51 ;;         etc (see `package-get-base').
  52 ;;      4. The maintainer posts an announcement with the new version
  53 ;;         of `package-get-base'.
  54 ;;      5. A user/system manager saves this posting and runs
  55 ;;         `package-get-update' which uses the previously saved list
  56 ;;         of packages, `package-get-here' that the user/site
  57 ;;         wants to determine what new versions to download and
  58 ;;         install.
  59 ;;
  60 ;;      A user/site manager can generate a new `package-get-here' structure
  61 ;;      by using `package-get-setup' which generates a customize like
  62 ;;      interface to the list of packages.  The buffer looks something
  63 ;;      like:
  64 ;;
  65 ;;      gnus    - a mail and news reader
  66 ;;      []      Always install
  67 ;;      []      Needs updating
  68 ;;      []      Required by other [packages]
  69 ;;      version: 2.0
  70 ;;
  71 ;;      vm      - a mail reader
  72 ;;      []      Always install
  73 ;;      []      Needs updating
  74 ;;      []      Required by other [packages]
  75 ;;
  76 ;;      Where `[]' indicates a toggle box
  77 ;;
  78 ;;      - Clicking on "Always install" puts this into
  79 ;;        `package-get-here' list.  "Needs updating" indicates a new
  80 ;;        version is available.  Anything already in
  81 ;;        `package-get-here' has this enabled.
  82 ;;      - "Required by other" means some other packages are going to force
  83 ;;        this to be installed.  Clicking on  [packages] gives a list
  84 ;;        of packages that require this.
  85 ;;
  86 ;;      The `package-get-base' should be installed in a file in
  87 ;;      `data-directory'.  The `package-get-here' should be installed in
  88 ;;      site-lisp.  Both are then read at run time.
  89 ;;
  90 ;; TODO:
  91 ;;      - Implement `package-get-setup'
  92 ;;      - Actually put `package-get-base' and `package-get-here' into
  93 ;;        files that are read.
  94 ;;      - SOMEONE needs to write the programs that generate the
  95 ;;        provides/requires database and makes it into a lisp data
  96 ;;        structure suitable for `package-get-base'
  97 ;;      - Handle errors such as no package providing a required symbol.
  98 ;;      - Tie this into the `require' function to download packages
  99 ;;        transparently.
 100
 101 ;;; Change Log
 102
 103 ;;; Code:
 104
 105 (require 'package-admin)
 106 ;; (require 'package-get-base)
 107
 108 (defgroup package-tools nil
 109   "Tools to manipulate packages."
 110   :group 'emacs)
 111
 112 (defgroup package-get nil
 113   "Automatic Package Fetcher and Installer."
 114   :prefix "package-get"
 115   :group 'package-tools)
 116
 117 ;;;###autoload
 118 (defvar package-get-base nil
 119   "List of packages that are installed at this site.
 120 For each element in the alist,  car is the package name and the cdr is
 121 a plist containing information about the package.   Typical fields
 122 kept in the plist are:
 123
 124 version         - version of this package
 125 provides        - list of symbols provided
 126 requires        - list of symbols that are required.
 127                   These in turn are provided by other packages.
 128 filename        - name of the file.
 129 size            - size of the file (aka the bundled package)
 130 md5sum          - computed md5 checksum
 131 description     - What this package is for.
 132 type            - Whether this is a 'binary (default) or 'single file package
 133
 134 More fields may be added as needed.  An example:
 135
 136 '(
 137  (name
 138   (version \"<version 2>\"
 139    file \"filename\"
 140    description \"what this package is about.\"
 141    provides (<list>)
 142    requires (<list>)
 143    size <integer-bytes>
 144    md5sum \"<checksum\"
 145    type single
 146    )
 147   (version \"<version 1>\"
 148    file \"filename\"
 149    description \"what this package is about.\"
 150    provides (<list>)
 151    requires (<list>)
 152    size <integer-bytes>
 153    md5sum \"<checksum\"
 154    type single
 155    )
 156    ...
 157    ))
 158
 159 For version information, it is assumed things are listed in most
 160 recent to least recent -- in other words, the version names don't have to
 161 be lexically ordered.  It is debatable if it makes sense to have more than
 162 one version of a package available.")
 163
 164 (defcustom package-get-dir (temp-directory)
 165   "*Where to store temporary files for staging."
 166   :tag "Temporary directory"
 167   :type 'directory
 168   :group 'package-get)
 169
 170 ;;;###autoload
 171 (defcustom package-get-package-index-file-location
 172   (car (split-path (or (getenv "EMACSPACKAGEPATH") user-packages-topdir)))
 173   "*The directory where the package-index file can be found."
 174   :type 'directory
 175   :group 'package-get)
 176
 177 ;;;###autoload
 178 (defcustom package-get-install-to-user-directory nil
 179   "*If non-nil install packages under `user-packages-topdir'."
 180   :type 'boolean
 181   :group 'package-get)
 182
 183 (defvaralias 'package-get-install-to-user-init-directory
 184   'package-get-install-to-user-directory)
 185
 186 (define-widget 'host-name 'string
 187   "A Host name."
 188   :tag "Host")
 189
 190 (defcustom package-get-remote nil
 191   "*The remote site to contact for downloading packages.
 192 Format is '(site-name directory-on-site).  As a special case, `site-name'
 193 can be `nil', in which case `directory-on-site' is treated as a local
 194 directory."
 195   :tag "Package repository"
 196   :type '(set (choice (const :tag "None" nil)
 197                       (list :tag "Local" (const :tag "Local" nil) directory)
 198                       (list :tag "Remote" host-name directory)))
 199   :group 'package-get)
 200
 201 ;;;###autoload
 202 (defcustom package-get-download-sites
 203   '(
 204     ;; Main XEmacs Site (ftp.xemacs.org)
 205     ("US (Main XEmacs Site)"
 206      "ftp.xemacs.org" "pub/xemacs/packages")
 207     ;; In alphabetical order of Country, our mirrors...
 208     ;; Timing out
 209     ("Belgium (be.xemacs.org)" "ftp.be.xemacs.org" "xemacs/packages")
 210     ("Canada (ca.xemacs.org)" "ftp.ca.xemacs.org" "pub/Mirror/xemacs/packages")
 211     ("Denmark (dk.xemacs.org)" "ftp.dk.xemacs.org" "xemacs/packages")
 212     ;; Very outdated, last sumo updated Feb 2009,
 213     ("Finland (fi.xemacs.org)" "ftp.fi.xemacs.org" "pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/packages")
 214     ("France (fr.xemacs.org)" "ftp.fr.xemacs.org" "pub/xemacs/packages")
 215     ;; Temporary errors?
 216     ("France (mirror.cict.fr)" "mirror.cict.fr" "xemacs/packages")
 217     ("France (pasteur.fr)" "ftp.pasteur.fr" "pub/computing/xemacs/packages")
 218     ;; Very outdated, experimental not updated since 2013
 219     ("Germany (de.xemacs.org)" "ftp.de.xemacs.org" "pub/ftp.xemacs.org/tux/xemacs/packages")
 220     ;; Timing out
 221     ("Greece (gr.xemacs.org)" "ftp.gr.xemacs.org" "mirrors/XEmacs/ftp/packages")
 222     ;; Timing out
 223     ("Ireland (ie.xemacs.org)" "ftp.ie.xemacs.org" "mirrors/ftp.xemacs.org/pub/xemacs/packages")
 224     ("Ireland (heanet.ie)" "ftp.heanet.ie" "mirrors/ftp.xemacs.org/packages")
 225     ;; Timing out
 226     ("Italy (it.xemacs.org)" "ftp.it.xemacs.org" "unix/packages/XEMACS/packages")
 227     ;; Timing out
 228     ("Japan (dti.ad.jp)" "ftp.dti.ad.jp" "pub/unix/editor/xemacs/packages")
 229     ;; Timing out
 230     ("Korea (kr.xemacs.org)" "ftp.kr.xemacs.org" "pub/tools/emacs/xemacs/packages")
 231     ;; Timing out
 232     ("Netherlands (nl.xemacs.org)" "ftp.nl.xemacs.org" "pub/xemacs/ftp/packages")
 233     ;; no anonymous ftp available, uncomment when updating website
 234     ;; with
 235     ;; xemacs-builds/adrian/website/package-get-2-download-sites.el
 236 ;     ("Netherlands (xemacsftp.digimirror.nl)" "xemacsftp.digimirror.nl" "packages")
 237     ("Norway (no.xemacs.org)" "ftp.no.xemacs.org" "pub/xemacs/packages")
 238     ("Portugal (pt.xemacs.org)" "ftp.pt.xemacs.org" "pub/MIRRORS/ftp.xemacs.org/packages")
 239     ;; Timing out
 240     ("Russia (ru.xemacs.org)" "ftp.ru.xemacs.org" "pub/emacs/xemacs/packages")
 241     ("Sweden (se.xemacs.org)" "ftp.se.xemacs.org" "pub/gnu/xemacs/packages")
 242     ("Taiwan (ftp.tw.xemacs.org)" "ftp.tw.xemacs.org" "Unix/Editors/XEmacs/packages")
 243     ("UK (uk.xemacs.org)" "ftp.uk.xemacs.org" "sites/ftp.xemacs.org/pub/xemacs/packages")
 244     ("US (ibiblio.org)" "mirrors.ibiblio.org" "pub/mirrors/xemacs/packages")
 245     )
 246   "*List of remote sites available for downloading packages.
 247 List format is '(site-description site-name directory-on-site).
 248 SITE-DESCRIPTION is a textual description of the site.  SITE-NAME
 249 is the internet address of the download site.  DIRECTORY-ON-SITE
 250 is the directory on the site in which packages may be found.
 251 This variable is used to initialize `package-get-remote', the
 252 variable actually used to specify package download sites."
 253   :tag "Package download sites"
 254   :type '(repeat (list (string :tag "Name") host-name directory))
 255   :group 'package-get)
 256
 257 ;;;###autoload
 258 (defcustom package-get-pre-release-download-sites
 259   '(
 260     ;; Main XEmacs Site (ftp.xemacs.org)
 261     ("US Pre-Releases (Main XEmacs Site)" "ftp.xemacs.org"
 262      "pub/xemacs/beta/experimental/packages")
 263     ;; In alphabetical order of Country, our mirrors...
 264     ;; Timing out
 265     ("Belgium Pre-Releases (be.xemacs.org)" "ftp.be.xemacs.org"
 266      "xemacs/beta/experimental/packages")
 267     ("Canada Pre-Releases (ca.xemacs.org)" "ftp.ca.xemacs.org"
 268      "pub/Mirror/xemacs/beta/experimental/packages")
 269     ("Denmark Pre-Releases (dk.xemacs.org)" "ftp.dk.xemacs.org"
 270      "xemacs/beta/experimental/packages")
 271     ;; Very outdated, last sumo updated Feb 2009,
 272     ("Finland Pre-Releases (fi.xemacs.org)" "ftp.fi.xemacs.org"
 273      "pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/beta/experimental/packages")
 274     ("France Pre-Releases (fr.xemacs.org)" "ftp.fr.xemacs.org"
 275      "pub/xemacs/beta/experimental/packages")
 276     ;; Temporary errors?
 277     ("France Pre-Releases (mirror.cict.fr)" "mirror.cict.fr"
 278      "xemacs/beta/experimental/packages")
 279     ("France Pre-Releases (pasteur.fr)" "ftp.pasteur.fr"
 280      "pub/computing/xemacs/beta/experimental/packages")
 281     ;; Very outdated, experimental not updated since 2013
 282     ("Germany Pre-Releases (de.xemacs.org)" "ftp.de.xemacs.org"
 283      "pub/ftp.xemacs.org/tux/xemacs/beta/experimental/packages")
 284     ;; Timing out
 285     ("Greece Pre-Releases (gr.xemacs.org)" "ftp.gr.xemacs.org"
 286      "mirrors/XEmacs/ftp/beta/experimental/packages")
 287     ;; Timing out
 288     ("Ireland Pre-Releases (ie.xemacs.org)" "ftp.ie.xemacs.org"
 289      "mirrors/ftp.xemacs.org/pub/xemacs/beta/experimental/packages")
 290     ("Ireland Pre-Releases (heanet.ie)" "ftp.heanet.ie"
 291      "mirrors/ftp.xemacs.org/beta/experimental/packages")
 292     ;; Timing out
 293     ("Italy Pre-Releases (it.xemacs.org)" "ftp.it.xemacs.org"
 294      "unix/packages/XEMACS/beta/experimental/packages")
 295     ;; Timing out
 296     ("Japan Pre-Releases (dti.ad.jp)" "ftp.dti.ad.jp"
 297      "pub/unix/editor/xemacs/beta/experimental/packages")
 298     ;; Timing out
 299     ("Korea Pre-Releases (kr.xemacs.org)" "ftp.kr.xemacs.org"
 300      "pub/tools/emacs/xemacs/beta/experimental/packages")
 301     ;; Timing out
 302     ("Netherlands Pre-Releases (nl.xemacs.org)" "ftp.nl.xemacs.org"
 303      "pub/xemacs/ftp/beta/experimental/packages")
 304     ;; no anonymous ftp available, uncomment when updating website
 305     ;; with
 306     ;; xemacs-builds/adrian/website/package-get-2-download-sites.el
 307     ;; ("Netherlands Pre-Releases (xemacsftp.digimirror.nl)" "xemacsftp.digimirror.nl"
 308     ;;  "beta/experimental/packages")
 309     ("Norway Pre-Releases (no.xemacs.org)" "ftp.no.xemacs.org"
 310      "pub/xemacs/beta/experimental/packages")
 311     ("Portugal Pre-Releases (pt.xemacs.org)" "ftp.pt.xemacs.org"
 312      "pub/MIRRORS/ftp.xemacs.org/beta/experimental/packages")
 313     ;; Timing out
 314     ("Russia Pre-Releases (ru.xemacs.org)" "ftp.ru.xemacs.org"
 315      "pub/emacs/xemacs/beta/experimental/packages")
 316     ("Sweden Pre-Releases (se.xemacs.org)" "ftp.se.xemacs.org"
 317      "pub/gnu/xemacs/beta/experimental/packages")
 318     ("Taiwan Pre-Releases (ftp.tw.xemacs.org)" "ftp.tw.xemacs.org"
 319      "Unix/Editors/XEmacs/beta/experimental/packages")
 320     ("UK Pre-Releases (uk.xemacs.org)" "ftp.uk.xemacs.org"
 321      "sites/ftp.xemacs.org/pub/xemacs/beta/experimental/packages")
 322     ("US Pre-Releases (ibiblio.org)" "mirrors.ibiblio.org"
 323      "pub/mirrors/xemacs/beta/experimental/packages")
 324     )
 325   "*List of remote sites available for downloading \"Pre-Release\" packages.
 326 List format is '(site-description site-name directory-on-site).
 327 SITE-DESCRIPTION is a textual description of the site.  SITE-NAME
 328 is the internet address of the download site.  DIRECTORY-ON-SITE
 329 is the directory on the site in which packages may be found.
 330 This variable is used to initialize `package-get-remote', the
 331 variable actually used to specify package download sites."
 332   :tag "Pre-Release Package download sites"
 333   :type '(repeat (list (string :tag "Name") host-name directory))
 334   :group 'package-get)
 335
 336 ;;;###autoload
 337 (defcustom package-get-site-release-download-sites
 338   nil
 339   "*List of remote sites available for downloading \"Site Release\" packages.
 340 List format is '(site-description site-name directory-on-site).
 341 SITE-DESCRIPTION is a textual description of the site.  SITE-NAME
 342 is the internet address of the download site.  DIRECTORY-ON-SITE
 343 is the directory on the site in which packages may be found.
 344 This variable is used to initialize `package-get-remote', the
 345 variable actually used to specify package download sites."
 346   :tag "Site Release Package download sites"
 347   :type '(repeat (list (string :tag "Name") host-name directory))
 348   :group 'package-get)
 349
 350 (defcustom package-get-remove-copy t
 351   "*After copying and installing a package, if this is t, then remove the
 352 copy.  Otherwise, keep it around."
 353   :type 'boolean
 354   :group 'package-get)
 355
 356 ;; #### it may make sense for this to be a list of names.
 357 ;; #### also, should we rename "*base*" to "*index*" or "*db*"?
 358 ;;      "base" is a pretty poor name.
 359 (defcustom package-get-base-filename "package-index.LATEST.gpg"
 360   "*Name of the default package-get database file.
 361 This may either be a relative path, in which case it is interpreted
 362 with respect to `package-get-remote', or an absolute path."
 363   :type 'file
 364   :group 'package-get)
 365
 366 (defcustom package-get-always-update nil
 367   "*If Non-nil always make sure we are using the latest package index (base).
 368 Otherwise respect the `force-current' argument of `package-get-require-base'."
 369   :type 'boolean
 370   :group 'package-get)
 371
 372 (defvar package-get-was-current nil
 373   "Non-nil we did our best to fetch a current database.")
 374
 375 ;;;###autoload
 376 (defun package-get-require-base (&optional force-current)
 377   "Require that a package-get database has been loaded.
 378 If the optional FORCE-CURRENT argument or the value of
 379 `package-get-always-update' is Non-nil, try to update the database
 380 from a location in `package-get-remote'. Otherwise a local copy is used
 381 if available and remote access is never done.
 382
 383 Please use FORCE-CURRENT only when the user is explictly dealing with packages
 384 and remote access is likely in the near future."
 385   (setq force-current (or force-current package-get-always-update))
 386   (unless (and (boundp 'package-get-base)
 387                package-get-base
 388                (or (not force-current) package-get-was-current))
 389     (package-get-update-base nil force-current))
 390   (if (or (not (boundp 'package-get-base))
 391           (not package-get-base))
 392       (error 'void-variable
 393              "Package-get database not loaded")
 394     (setq package-get-was-current force-current)))
 395
 396 ;;;###autoload
 397 (defun package-get-update-base-entry (entry)
 398   "Update an entry in `package-get-base'."
 399   (let ((existing (assq (car entry) package-get-base)))
 400     (if existing
 401         (setcdr existing (cdr entry))
 402       (setq package-get-base (cons entry package-get-base)))))
 403
 404 (defun package-get-locate-file (file &optional nil-if-not-found no-remote)
 405   "Locate an existing FILE with respect to `package-get-remote'.
 406 If FILE is an absolute path or is not found, simply return FILE.
 407 If optional argument NIL-IF-NOT-FOUND is non-nil, return nil
 408 if FILE can not be located.
 409 If NO-REMOTE is non-nil never search remote locations."
 410   (if (file-name-absolute-p file)
 411       file
 412     (let ((site package-get-remote)
 413           (expanded nil))
 414       (when site
 415         (unless (and no-remote (caar (list site)))
 416           (let ((expn (package-get-remote-filename (car (list site)) file)))
 417             (if (and expn (file-exists-p expn))
 418                 (setq site nil
 419                       expanded expn)))))
 420       (or expanded
 421           (and (not nil-if-not-found)
 422                file)))))
 423
 424 (defun package-get-locate-index-file (no-remote)
 425   "Locate the package-get index file.
 426
 427 Do not return remote paths if NO-REMOTE is non-nil.  If the index
 428 file doesn't exist in `package-get-package-index-file-location', ask
 429 the user if one should be created using the index file in core as a
 430 template."
 431   (or (package-get-locate-file package-get-base-filename t no-remote)
 432       (if (file-exists-p (expand-file-name package-get-base-filename
 433                                            package-get-package-index-file-location))
 434           (expand-file-name package-get-base-filename
 435                             package-get-package-index-file-location)
 436         (if (y-or-n-p (format "No index file, shall I create one in %s? "
 437                               package-get-package-index-file-location))
 438             (progn
 439               (save-excursion
 440                 (set-buffer
 441                  (find-file-noselect (expand-file-name
 442                                       package-get-base-filename
 443                                       package-get-package-index-file-location)))
 444                 (let ((coding-system-for-write 'binary))
 445                   (erase-buffer)
 446                   (insert-file-contents-literally
 447                    (locate-data-file package-get-base-filename))
 448                   (save-buffer (current-buffer))
 449                   (kill-buffer (current-buffer))))
 450               (expand-file-name package-get-base-filename
 451                                 package-get-package-index-file-location))
 452           (error 'search-failed
 453                  "Can't locate a package index file.")))))
 454
 455 (defun package-get-maybe-save-index (filename)
 456   "Offer to save the current buffer as the local package index file,
 457 if different."
 458   (let ((location (package-get-locate-index-file t)))
 459     (unless (and filename (equal filename location))
 460       (unless (and location
 461                    (equal (md5 (current-buffer))
 462                           (with-temp-buffer
 463                             (insert-file-contents-literally location)
 464                             (md5 (current-buffer)))))
 465         (when (not (file-writable-p location))
 466           (if (y-or-n-p (format "Sorry, %s is read-only, can I use %s? "
 467                                 location user-packages-topdir))
 468               (setq location (expand-file-name
 469                               package-get-base-filename
 470                               package-get-package-index-file-location))
 471             (error 'file-error
 472                    (format "%s is read-only" location))))
 473         (when (y-or-n-p (concat "Update package index in " location "? "))
 474           (let ((coding-system-for-write 'binary))
 475             (write-file location)))))))
 476
 477 ;;;###autoload
 478 (defun package-get-update-base (&optional db-file force-current)
 479   "Update the package-get database file with entries from DB-FILE.
 480 Unless FORCE-CURRENT is non-nil never try to update the database."
 481   (interactive
 482    (let ((dflt (package-get-locate-index-file nil)))
 483      (list (read-file-name "Load package-get database: "
 484                            (file-name-directory dflt)
 485                            dflt
 486                            t
 487                            (file-name-nondirectory dflt)))))
 488   (setq db-file (expand-file-name (or db-file
 489                                       (package-get-locate-index-file
 490                                          (not force-current)))))
 491   (if (not (file-exists-p db-file))
 492       (error 'file-error
 493              (format "Package-get database file `%s' does not exist" db-file)))
 494   (if (not (file-readable-p db-file))
 495       (error 'file-error
 496              (format "Package-get database file `%s' not readable" db-file)))
 497   (let ((buf (get-buffer-create "*package database*")))
 498     (unwind-protect
 499         (save-excursion
 500           (set-buffer buf)
 501           (erase-buffer buf)
 502           (insert-file-contents-literally db-file)
 503           (package-get-update-base-from-buffer buf)
 504           (if (file-remote-p db-file)
 505               (package-get-maybe-save-index db-file)))
 506       (kill-buffer buf))))
 507
 508 ;; This is here because the `process-error' datum doesn't exist in
 509 ;; 21.4. --SY.
 510 (define-error 'process-error "Process error")
 511
 512 ;;;###autoload
 513 (defun package-get-update-base-from-buffer (&optional buf)
 514   "Update the package-get database with entries from BUFFER.
 515 BUFFER defaults to the current buffer.  This command can be
 516 used interactively, for example from a mail or news buffer."
 517   (interactive)
 518   (setq buf (or buf (current-buffer)))
 519   (let ((coding-system-for-read 'binary)
 520         (coding-system-for-write 'binary)
 521         content-beg content-end)
 522     (save-excursion
 523       (set-buffer buf)
 524       (goto-char (point-min))
 525       (setq content-beg (point))
 526       (setq content-end (save-excursion (goto-char (point-max)) (point)))
 527       (package-get-update-base-entries content-beg content-end)
 528       (message "Updated package database"))))
 529
 530 (defun package-get-update-base-entries (start end)
 531   "Update the package-get database with the entries found between
 532 START and END in the current buffer."
 533   (save-excursion
 534     (goto-char start)
 535     (if (not (re-search-forward "^(package-get-update-base-entry" nil t))
 536         (error 'search-failed
 537                "Buffer does not contain package-get database entries"))
 538     (beginning-of-line)
 539     (let ((count 0))
 540       (while (and (< (point) end)
 541                   (re-search-forward "^(package-get-update-base-entry" nil t))
 542         (beginning-of-line)
 543         (let ((entry (read (current-buffer))))
 544           (if (or (not (consp entry))
 545                   (not (eq (car entry) 'package-get-update-base-entry)))
 546               (error 'syntax-error
 547                      "Invalid package-get database entry found"))
 548           (package-get-update-base-entry
 549            (car (cdr (car (cdr entry)))))
 550           (setq count (1+ count))))
 551       (message "Got %d package-get database entries" count))))
 552
 553 ;;;###autoload
 554 (defun package-get-save-base (file)
 555   "Write the package-get database to FILE.
 556
 557 Note: This database will be unsigned of course."
 558   (interactive "FSave package-get database to: ")
 559   (package-get-require-base t)
 560   (let ((buf (get-buffer-create "*package database*")))
 561     (unwind-protect
 562         (save-excursion
 563           (set-buffer buf)
 564           (erase-buffer buf)
 565           (goto-char (point-min))
 566           (let ((entries package-get-base) entry plist)
 567             (insert ";; Package Index file -- Do not edit manually.\n")
 568             (insert ";;;@@@\n")
 569             (while entries
 570               (setq entry (car entries))
 571               (setq plist (car (cdr entry)))
 572               (insert "(package-get-update-base-entry (quote\n")
 573               (insert (format "(%s\n" (symbol-name (car entry))))
 574               (while plist
 575                 (insert (format "  %s%s %S\n"
 576                                 (if (eq plist (car (cdr entry))) "(" " ")
 577                                 (symbol-name (car plist))
 578                                 (car (cdr plist))))
 579                 (setq plist (cdr (cdr plist))))
 580               (insert "))\n))\n;;;@@@\n")
 581               (setq entries (cdr entries))))
 582           (insert ";; Package Index file ends here\n")
 583           (write-region (point-min) (point-max) file))
 584       (kill-buffer buf))))
 585
 586 (defun package-get-interactive-package-query (get-version package-symbol)
 587   "Perform interactive querying for package and optional version.
 588 Query for a version if GET-VERSION is non-nil.  Return package name as
 589 a symbol instead of a string if PACKAGE-SYMBOL is non-nil.
 590 The return value is suitable for direct passing to `interactive'."
 591   (package-get-require-base t)
 592   (let ((table (mapcar #'(lambda (item)
 593                            (let ((name (symbol-name (car item))))
 594                              (cons name name)))
 595                        package-get-base))
 596         package package-symbol default-version version)
 597     (save-window-excursion
 598       (setq package (completing-read "Package: " table nil t))
 599       (setq package-symbol (intern package))
 600       (if get-version
 601           (progn
 602             (setq default-version
 603                   (package-get-info-prop
 604                    (package-get-info-version
 605                     (package-get-info-find-package package-get-base
 606                                                    package-symbol) nil)
 607                    'version))
 608             (while (string=
 609                     (setq version (read-string "Version: " default-version))
 610                     ""))
 611             (if package-symbol
 612                 (list package-symbol version)
 613               (list package version)))
 614         (if package-symbol
 615             (list package-symbol)
 616           (list package))))))
 617
 618 ;;;###autoload
 619 (defun package-get-delete-package (package &optional pkg-topdir)
 620   "Delete an installation of PACKAGE below directory PKG-TOPDIR.
 621 PACKAGE is a symbol, not a string.
 622 This is just an interactive wrapper for `package-admin-delete-binary-package'."
 623   (interactive (package-get-interactive-package-query nil t))
 624   (package-admin-delete-binary-package package pkg-topdir))
 625
 626 ;;;###autoload
 627 (defun package-get-update-all ()
 628   "Fetch and install the latest versions of all currently installed packages."
 629   (interactive)
 630   (package-get-require-base t)
 631   ;; Load a fresh copy
 632   (catch 'exit
 633     (mapcar (lambda (pkg)
 634               (if (not (package-get (car pkg) nil 'never))
 635                   (throw 'exit nil)))           ;; Bail out if error detected
 636             packages-package-list)))
 637
 638 ;;;###autoload
 639 (defun package-get-all (package version &optional fetched-packages install-dir)
 640   "Fetch PACKAGE with VERSION and all other required packages.
 641 Uses `package-get-base' to determine just what is required and what
 642 package provides that functionality.  If VERSION is nil, retrieves
 643 latest version.  Optional argument FETCHED-PACKAGES is used to keep
 644 track of packages already fetched.  Optional argument INSTALL-DIR,
 645 if non-nil, specifies the package directory where fetched packages
 646 should be installed.
 647
 648 Returns nil upon error."
 649   (interactive (package-get-interactive-package-query t nil))
 650   (let* ((the-package (package-get-info-find-package package-get-base
 651                                                      package))
 652          (this-package (package-get-info-version
 653                         the-package version))
 654          (this-requires (package-get-info-prop this-package 'requires)))
 655     (catch 'exit
 656       (setq version (package-get-info-prop this-package 'version))
 657       (unless (package-get-installedp package version)
 658         (if (not (package-get package version nil install-dir))
 659             (progn
 660               (setq fetched-packages nil)
 661               (throw 'exit nil))))
 662       (setq fetched-packages
 663             (append (list package)
 664                     (package-get-info-prop this-package 'provides)
 665                     fetched-packages))
 666       ;; grab everything that this package requires plus recursively
 667       ;; grab everything that the requires require.  Keep track
 668       ;; in `fetched-packages' the list of things provided -- this
 669       ;; keeps us from going into a loop
 670       (while this-requires
 671         (if (not (member (car this-requires) fetched-packages))
 672             (let* ((reqd-package (package-get-package-provider
 673                                   (car this-requires) t))
 674                    (reqd-version (cadr reqd-package))
 675                    (reqd-name (car reqd-package)))
 676               (if (null reqd-name)
 677                   (error 'search-failed
 678                          (format "Unable to find a provider for %s"
 679                                  (car this-requires))))
 680               (if (not (setq fetched-packages
 681                              (package-get-all reqd-name reqd-version
 682                                               fetched-packages
 683                                               install-dir)))
 684                   (throw 'exit nil))))
 685         (setq this-requires (cdr this-requires))))
 686     fetched-packages))
 687
 688 ;;;###autoload
 689 (defun package-get-dependencies (packages)
 690   "Compute dependencies for PACKAGES.
 691 Uses `package-get-base' to determine just what is required and what
 692 package provides that functionality.  Returns the list of packages
 693 required by PACKAGES."
 694   (package-get-require-base t)
 695   (let ((orig-packages packages)
 696         dependencies provided)
 697     (while packages
 698       (let* ((package (car packages))
 699              (the-package (package-get-info-find-package
 700                            package-get-base package))
 701              (this-package (package-get-info-version
 702                             the-package nil))
 703              (this-requires (package-get-info-prop this-package 'requires))
 704              (new-depends   (set-difference
 705                              (mapcar
 706                               #'(lambda (reqd)
 707                                   (let* ((reqd-package (package-get-package-provider reqd))
 708                                          (reqd-name    (car reqd-package)))
 709                                     (if (null reqd-name)
 710                                         (error 'search-failed
 711                                                (format "Unable to find a provider for %s" reqd)))
 712                                     reqd-name))
 713                               this-requires)
 714                              dependencies))
 715              (this-provides (package-get-info-prop this-package 'provides)))
 716         (setq dependencies
 717               (union dependencies new-depends))
 718         (setq provided
 719               (union provided (union (list package) this-provides)))
 720         (setq packages
 721               (union new-depends (cdr packages)))))
 722     (set-difference dependencies orig-packages)))
 723
 724 (defun package-get-load-package-file (lispdir file)
 725   (let (pathname)
 726     (setq pathname (expand-file-name file lispdir))
 727     (condition-case err
 728         (progn
 729           (load pathname t)
 730           t)
 731       (t
 732        (message "Error loading package file \"%s\" %s!" pathname err)
 733        nil))
 734     ))
 735
 736 (defun package-get-init-package (lispdir)
 737   "Initialize the package.
 738 This really assumes that the package has never been loaded.  Updating
 739 a newer package can cause problems, due to old, obsolete functions in
 740 the old package.
 741
 742 Return `t' upon complete success, `nil' if any errors occurred."
 743   (progn
 744     (if (and lispdir
 745              (file-accessible-directory-p lispdir))
 746         (progn
 747           ;; Add lispdir to load-path if it doesn't already exist.
 748           ;; NOTE: this does not take symlinks, etc., into account.
 749           (if (let ((dirs load-path))
 750                 (catch 'done
 751                   (while dirs
 752                     (if (string-equal (car dirs) lispdir)
 753                         (throw 'done nil))
 754                     (setq dirs (cdr dirs)))
 755                   t))
 756               (setq load-path (cons lispdir load-path)))
 757           (if (not (package-get-load-package-file lispdir "auto-autoloads"))
 758               (package-get-load-package-file lispdir "_pkg"))
 759           t)
 760       nil)))
 761
 762 ;;;###autoload
 763 (defun package-get-info (package information &optional arg remote)
 764   "Get information about a package.
 765
 766 Quite similar to `package-get-info-prop', but can retrieve a lot more
 767 information.
 768
 769 Argument PACKAGE is the name of an XEmacs package (a symbol).  It must
 770 be a valid package, ie, a member of `package-get-base'.
 771
 772 Argument INFORMATION is a symbol that can be any one of:
 773
 774    standards-version     Package system version (not used).
 775    version               Version of the XEmacs package.
 776    author-version        The upstream version of the package.
 777    date                  The date the package was last modified.
 778    build-date            The date the package was last built.
 779    maintainer            The maintainer of the package.
 780    distribution          Will always be \"xemacs\" (not used).
 781    priority              \"low\", \"medium\", or \"high\" (not used).
 782    category              Either \"standard\", \"mule\", or \"unsupported\"..
 783    dump                  Is the package dumped (not used).
 784    description           A description of the package.
 785    filename              The filename of the binary tarball of the package.
 786    md5sum                The md5sum of filename.
 787    size                  The size in bytes of filename.
 788    provides              A list of symbols that this package provides.
 789    requires              A list of packages that this package requires.
 790    type                  Can be either \"regular\" or \"single-file\".
 791
 792 If optional argument ARG is non-nil insert INFORMATION into current
 793 buffer at point.  This is very useful for doing things like inserting
 794 a maintainer's email address into a mail buffer.
 795
 796 If optional argument REMOTE is non-nil use a package list from a
 797 remote site.  For this to work `package-get-remote' must be non-nil.
 798
 799 If this function is called interactively it will display INFORMATION
 800 in the minibuffer."
 801   (interactive "SPackage: \nSInfo: \nP")
 802     (if remote
 803         (package-get-require-base t)
 804       (package-get-require-base nil))
 805     (let ((all-pkgs package-get-base)
 806           info)
 807       (loop until (equal package (caar all-pkgs))
 808         do (setq all-pkgs (cdr all-pkgs))
 809         do (if (not all-pkgs)
 810                (error 'invalid-argument
 811                       (format "%s is not a valid package" package))))
 812       (setq info (plist-get (cadar all-pkgs) information))
 813       (if (interactive-p)
 814           (if arg
 815               (insert (format "%s" info))
 816             (if (package-get-key package :version)
 817                 (message "%s" info)
 818               (message "%s (Package: %s is not installed)" info package)))
 819         (if arg
 820             (insert (format "%s" info))
 821           info))))
 822
 823 ;;;###autoload
 824 (defun package-get-list-packages-where (item field &optional arg)
 825   "Return a list of packages that fulfill certain criteria.
 826
 827 Argument ITEM, a symbol, is what you want to check for.  ITEM must be a
 828 symbol even when it doesn't make sense to be a symbol \(think, searching
 829 maintainers, descriptions, etc\).  The function will convert the symbol
 830 to a string if a string is what is needed.  The downside to this is that
 831 ITEM can only ever be a single word.
 832
 833 Argument FIELD, a symbol, is the field to check in.  You can specify
 834 any one of:
 835
 836       Field            Sane or Allowable Content
 837     description          any single word
 838     category             `standard' or `mule'
 839     maintainer           any single word
 840     build-date           yyyy-mm-dd
 841     date                 yyyy-mm-dd
 842     type                 `regular' or `single'
 843     requires             any package name
 844     provides             any symbol
 845     priority             `low', `medium', or `high'
 846
 847 Optional Argument ARG, a prefix arg, insert output at point in the
 848 current buffer."
 849   (interactive "SList packages that have (item): \nSin their (field): \nP")
 850   (package-get-require-base nil)
 851   (let ((pkgs package-get-base)
 852         (strings '(description category maintainer build-date date))
 853         (symbols '(type requires provides priority))
 854         results)
 855     (cond ((memq field strings)
 856            (setq item (symbol-name item))
 857            (while pkgs
 858              (when (string-match item (package-get-info (caar pkgs) field))
 859                (setq results (push (caar pkgs) results)))
 860              (setq pkgs (cdr pkgs))))
 861           ((memq field symbols)
 862            (if (or (eq field 'type)
 863                    (eq field 'priority))
 864                (while pkgs
 865                  (when (eq item (package-get-info (caar pkgs) field))
 866                    (setq results (push (caar pkgs) results)))
 867                  (setq pkgs (cdr pkgs)))
 868              (while pkgs
 869                (when (memq item (package-get-info (caar pkgs) field))
 870                  (setq results (push (caar pkgs) results)))
 871                (setq pkgs (cdr pkgs)))))
 872           (t
 873            (error 'wrong-type-argument field)))
 874     (if (interactive-p)
 875         (if arg
 876             (insert (format "%s" results))
 877           (message "%s" results)))
 878     results))
 879
 880 ;;;###autoload
 881 (defun package-get (package &optional version conflict install-dir)
 882   "Fetch PACKAGE from remote site.
 883 Optional arguments VERSION indicates which version to retrieve, nil
 884 means most recent version.  CONFLICT indicates what happens if the
 885 package is already installed.  Valid values for CONFLICT are:
 886 'always always retrieve the package even if it is already installed
 887 'never  do not retrieve the package if it is installed.
 888 INSTALL-DIR, if non-nil, specifies the package directory where
 889 fetched packages should be installed.
 890
 891 The value of `package-get-base' is used to determine what files should
 892 be retrieved.  The value of `package-get-remote' is used to determine
 893 where a package should be retrieved from.
 894
 895 Once the package is retrieved, its md5 checksum is computed.  If that
 896 sum does not match that stored in `package-get-base' for this version
 897 of the package, an error is signalled.
 898
 899 Returns `t' upon success, the symbol `error' if the package was
 900 successfully installed but errors occurred during initialization, or
 901 `nil' upon error."
 902   (interactive (package-get-interactive-package-query nil t))
 903   (catch 'skip-update
 904   (let* ((this-package
 905           (package-get-info-version
 906            (package-get-info-find-package package-get-base
 907                                           package) version))
 908          (latest (package-get-info-prop this-package 'version))
 909          (installed (package-get-key package :version))
 910          (found nil)
 911          (host nil)
 912          (search-dir package-get-remote)
 913          (base-filename (package-get-info-prop this-package 'filename))
 914          (package-status t)
 915          filenames full-package-filename)
 916     (if (and (equal (package-get-info package 'category) "mule")
 917              (not (featurep 'mule)))
 918         (error 'invalid-state
 919                "Mule packages can't be installed with a non-Mule SXEmacs"))
 920     (if (null this-package)
 921         (if package-get-remote
 922             (error 'search-failed
 923                    (format "Couldn't find package %s with version %s"
 924                            package version))
 925           (error 'syntax-error
 926                  "No download site or local package location specified.")))
 927     (if (null base-filename)
 928         (error 'syntax-error
 929                (format "No filename associated with package %s, version %s"
 930                        package version)))
 931     (setq install-dir (package-admin-get-install-dir package install-dir))
 932
 933     ;; If they asked for the latest using version=nil, don't get an older
 934     ;; version than we already have.
 935     (if installed
 936         (if (> (if (stringp installed)
 937                    (string-to-number installed)
 938                  installed)
 939                (if (stringp latest)
 940                    (string-to-number latest)
 941                  latest))
 942             (if (not (null version))
 943                 (warn "Installing %s package version %s, you had a newer version %s"
 944                   package latest installed)
 945               (warn "Skipping %s package, you have a newer version %s"
 946                 package installed)
 947               (throw 'skip-update t))))
 948
 949     ;; Contrive a list of possible package filenames.
 950     ;; Ugly.  Is there a better way to do this?
 951     (setq filenames (cons base-filename nil))
 952     (if (string-match #r"^\(..*\)\.tar\.gz$" base-filename)
 953         (setq filenames (append filenames
 954                                 (list (concat (match-string 1 base-filename)
 955                                               ".tgz")))))
 956
 957     (setq version latest)
 958     (unless (and (eq conflict 'never)
 959                  (package-get-installedp package version))
 960       ;; Find the package from the search list in package-get-remote
 961       ;; and copy it into the staging directory.  Then validate
 962       ;; the checksum.  Finally, install the package.
 963       (catch 'done
 964         (let (search-filenames dir current-filename dest-filename)
 965           ;; In each search directory ...
 966           (when search-dir
 967             (setq host (car search-dir)
 968                   dir (car (cdr search-dir))
 969                   search-filenames filenames)
 970
 971             ;; Look for one of the possible package filenames ...
 972             (while search-filenames
 973               (setq current-filename (car search-filenames)
 974                     dest-filename (package-get-staging-dir current-filename))
 975               (cond
 976                ;; No host means look on the current system.
 977                ((null host)
 978                 (setq full-package-filename
 979                       (substitute-in-file-name
 980                        (expand-file-name current-filename
 981                                          (file-name-as-directory dir)))))
 982
 983                ;; If it's already on the disk locally, and the size is
 984                ;; correct
 985                ((and (file-exists-p dest-filename)
 986                      (eq (nth 7 (file-attributes dest-filename))
 987                          (package-get-info package 'size)))
 988                  (setq full-package-filename dest-filename))
 989
 990                ;; If the file exists on the remote system ...
 991                ((file-exists-p (package-get-remote-filename
 992                                 search-dir current-filename))
 993                 ;; Get it
 994                 (setq full-package-filename dest-filename)
 995                 (message "Retrieving package `%s' ..."
 996                          current-filename)
 997                 (sit-for 0)
 998                 (copy-file (package-get-remote-filename search-dir
 999                                                         current-filename)
1000                            full-package-filename t)))
1001
1002               ;; If we found it, we're done.
1003               (if (and full-package-filename
1004                        (file-exists-p full-package-filename))
1005                   (throw 'done nil))
1006               ;; Didn't find it.  Try the next possible filename.
1007               (setq search-filenames (cdr search-filenames))))))
1008
1009       (if (or (not full-package-filename)
1010               (not (file-exists-p full-package-filename)))
1011           (if package-get-remote
1012               (error 'search-failed
1013                      (format "Unable to find file %s" base-filename))
1014             (error 'syntax-error
1015                    "No download sites or local package locations specified.")))
1016       ;; Validate the md5 checksum
1017       ;; Doing it with SXEmacs removes the need for an external md5 program
1018       (message "Validating checksum for `%s'..." package) (sit-for 0)
1019       (with-temp-buffer
1020         (insert-file-contents-literally full-package-filename)
1021         (if (not (string= (md5 (current-buffer))
1022                           (package-get-info-prop this-package
1023                                                  'md5sum)))
1024             (progn
1025               (unless (null host)
1026                 (delete-file full-package-filename))
1027               (error 'process-error
1028                      (format "Package %s does not match md5 checksum %s has been deleted"
1029                              base-filename full-package-filename)))))
1030
1031       (package-admin-delete-binary-package package install-dir)
1032
1033       (message "Installing package `%s' ..." package) (sit-for 0)
1034       (let ((status
1035              (package-admin-add-binary-package full-package-filename
1036                                                install-dir)))
1037         (if (= status 0)
1038             (progn
1039               ;; clear messages so that only messages from
1040               ;; package-get-init-package are seen, below.
1041               (clear-message)
1042               (if (package-get-init-package (package-admin-get-lispdir
1043                                              install-dir package))
1044                   (progn
1045                     (run-hook-with-args 'package-install-hook package install-dir)
1046                     (message "Added package `%s'" package)
1047                     (sit-for 0))
1048                 (progn
1049                   ;; display message only if there isn't already one.
1050                   (if (not (current-message))
1051                       (progn
1052                         (message "Added package `%s' (errors occurred)"
1053                                  package)
1054                         (sit-for 0)))
1055                   (if package-status
1056                       (setq package-status 'errors)))))
1057           (message "Installation of package %s failed." base-filename)
1058           (sit-for 0)
1059           (switch-to-buffer package-admin-temp-buffer)
1060           ;; null host means a local package mirror
1061           (unless (null host)
1062             (delete-file full-package-filename))
1063           (setq package-status nil)))
1064       (setq found t))
1065     (if (and found package-get-remove-copy (not (null host)))
1066         (delete-file full-package-filename))
1067     package-status)))
1068
1069 (defun package-get-info-find-package (which name)
1070   "Look in WHICH for the package called NAME and return all the info
1071 associated with it.  See `package-get-base' for info on the format
1072 returned.
1073
1074  To access fields returned from this, use
1075 `package-get-info-version' to return information about particular a
1076 version.  Use `package-get-info-find-prop' to find particular property
1077 from a version returned by `package-get-info-version'."
1078   (interactive "xPackage list: \nsPackage Name: ")
1079   (if which
1080       (if (eq (caar which) name)
1081           (cdar which)
1082         (if (cdr which)
1083             (package-get-info-find-package (cdr which) name)))))
1084
1085 (defun package-get-info-version (package version)
1086   "In PACKAGE, return the plist associated with a particular VERSION of the
1087   package.  PACKAGE is typically as returned by
1088   `package-get-info-find-package'.  If VERSION is nil, then return the
1089   first (aka most recent) version.  Use `package-get-info-find-prop'
1090   to retrieve a particular property from the value returned by this."
1091   (interactive (package-get-interactive-package-query t t))
1092   (while (and version package (not (string= (plist-get (car package) 'version) version)))
1093     (setq package (cdr package)))
1094   (if package (car package)))
1095
1096 (defun package-get-info-prop (package-version property)
1097   "In PACKAGE-VERSION, return the value associated with PROPERTY.
1098 PACKAGE-VERSION is typically returned by `package-get-info-version'
1099 and PROPERTY is typically (although not limited to) one of the
1100 following:
1101
1102 version         - version of this package
1103 provides                - list of symbols provided
1104 requires                - list of symbols that are required.
1105                   These in turn are provided by other packages.
1106 size            - size of the bundled package
1107 md5sum          - computed md5 checksum"
1108   (interactive "xPackage Version: \nSProperty")
1109   (plist-get package-version property))
1110
1111 (defun package-get-info-version-prop (package-list package version property)
1112   "In PACKAGE-LIST, search for PACKAGE with this VERSION and return
1113   PROPERTY value."
1114   (package-get-info-prop
1115    (package-get-info-version
1116     (package-get-info-find-package package-list package) version) property))
1117
1118 (defun package-get-staging-dir (filename)
1119   "Return a good place to stash FILENAME when it is retrieved.
1120 Use `package-get-dir' for directory to store stuff.
1121 Creates `package-get-dir'  if it doesn't exist."
1122   (interactive "FPackage filename: ")
1123   (if (not (file-exists-p package-get-dir))
1124       (make-directory package-get-dir))
1125   (expand-file-name
1126    (file-name-nondirectory (or (and-fboundp 'efs-ftp-path
1127                                  (nth 2 (efs-ftp-path filename)))
1128                                filename))
1129    (file-name-as-directory package-get-dir)))
1130
1131 (defun package-get-remote-filename (search filename)
1132   "Return FILENAME as a remote filename.
1133 It first checks if FILENAME already is a remote filename.  If it is
1134 not, then it uses the (car search) as the remote site-name and the (cadr
1135 search) as the remote-directory and concatenates filename.  In other
1136 words
1137         site-name:remote-directory/filename.
1138
1139 If (car search) is nil, (cadr search is interpreted as  a local directory).
1140 "
1141   (if (file-remote-p filename)
1142       filename
1143     (let ((dir (cadr search)))
1144       (concat (when (car search)
1145                 (concat
1146                  (if (string-match "@" (car search))
1147                      "/"
1148                    "/anonymous@")
1149                  (car search) ":"))
1150               (if (string-match "/$" dir)
1151                   dir
1152                 (concat dir "/"))
1153               filename))))
1154
1155 (defun package-get-installedp (package version)
1156   "Determine if PACKAGE with VERSION has already been installed.
1157 I'm not sure if I want to do this by searching directories or checking
1158 some built in variables.  For now, use packages-package-list."
1159   ;; Use packages-package-list which contains name and version
1160   (equal (plist-get
1161           (package-get-info-find-package packages-package-list
1162                                          package) ':version)
1163          (if (floatp version)
1164              version
1165            (string-to-number version))))
1166
1167 ;;;###autoload
1168 (defun package-get-package-provider (sym &optional force-current)
1169   "Search for a package that provides SYM and return the name and
1170   version.  Searches in `package-get-base' for SYM.   If SYM is a
1171   consp, then it must match a corresponding (provide (SYM VERSION)) from
1172   the package.
1173
1174 If FORCE-CURRENT is non-nil make sure the database is up to date. This might
1175 lead to Emacs accessing remote sites."
1176   (interactive "SSymbol: ")
1177   (package-get-require-base force-current)
1178   (let ((packages package-get-base)
1179         (done nil)
1180         (found nil))
1181     (while (and (not done) packages)
1182       (let* ((this-name (caar packages))
1183              (this-package (cdr (car packages)))) ;strip off package name
1184         (while (and (not done) this-package)
1185           (if (or (eq this-name sym)
1186                   (eq (cons this-name
1187                           (package-get-info-prop (car this-package) 'version))
1188                       sym)
1189                   (member sym
1190                         (package-get-info-prop (car this-package) 'provides)))
1191               (progn (setq done t)
1192                      (setq found
1193                        (list (caar packages)
1194                          (package-get-info-prop (car this-package) 'version))))
1195             (setq this-package (cdr this-package)))))
1196       (setq packages (cdr packages)))
1197     (when (interactive-p)
1198       (if found
1199           (message "%S" found)
1200         (message "No appropriate package found")))
1201     found))
1202
1203 (defun package-get-ever-installed-p (pkg &optional notused)
1204   (string-match "-package$" (symbol-name pkg))
1205   (custom-initialize-set
1206    pkg
1207    (if (package-get-info-find-package
1208         packages-package-list
1209         (intern (substring (symbol-name pkg) 0 (match-beginning 0))))
1210        t)))
1211
1212 ;;; FIXME: see comment at end of `pui-bootstrap'
1213
1214 ;;;###autoload
1215 (defun pui-bootstrap ()
1216   "Bootstrap the SXEmacs Package Tools.
1217
1218 The Package Tools, under normal circumstances, cannot work until a
1219 couple of packages are pre-installed by hand.  This function eliminates
1220 the need to do that.  It uses FFI and libcurl to download and install
1221 the lastest package index file, the EFS and xemacs-base packages.
1222
1223 Obviously you can't use this if you didn't enable FFI support in your
1224 SXEmacs or if you don't have libffi on your system.
1225
1226 This isn't designed to replace the existing Package Tools so after
1227 you have run `pui-bootstrap' once you should then use the normal PUI
1228 tools, `pui-list-packages' etc."
1229   (interactive)
1230   ;; A little sanity checking never hurt anybody
1231   (when (featurep '(and efs-autoloads xemacs-base-autoloads))
1232     (error 'invalid-operation "PUI doesn't need bootstrapping"))
1233   (when (and (fboundp 'ffi-defun)
1234              (not (featurep '(and ffi ffi-curl))))
1235     (require 'ffi-curl))
1236   (unless (featurep 'ffi)
1237     (error 'unimplemented "FFI"))
1238   ;; One last check... has `package-get-remote' been set?
1239   (if (not (cdr package-get-remote))
1240       (when (y-or-n-p "You haven't set a download site, do you need help ")
1241         (declare-fboundp (Info-goto-node "(sxemacs)Bootstrapping PUI")))
1242     ;; We should be good to go
1243     (let* ((site (car package-get-remote))
1244            (dir (cadr package-get-remote))
1245            (url (concat "ftp://" site "/" dir "/"))
1246            (dldir (temp-directory))
1247            (index (expand-file-name package-get-base-filename
1248                                     package-get-package-index-file-location))
1249            xemacs-base-pkg
1250            efs-pkg
1251                                         ;status)
1252            )
1253       ;; Grab the index
1254       (message "Retrieving index, please be patient")
1255       (declare-fboundp (curl:download (concat url package-get-base-filename) index))
1256       (message "Retrieving index, done!")
1257       ;; Update the db
1258       (set-buffer (find-file-noselect index))
1259       (package-get-update-base-from-buffer)
1260       (kill-buffer (current-buffer))
1261       ;; Get xemacs-base, EFS
1262       (setq xemacs-base-pkg (package-get-info 'xemacs-base 'filename))
1263       (setq efs-pkg (package-get-info 'efs 'filename))
1264       (message "Retrieving %s, please be patient" xemacs-base-pkg)
1265       (declare-fboundp (curl:download (concat url xemacs-base-pkg)
1266                                       (expand-file-name xemacs-base-pkg dldir)))
1267       (message "Retrieving %s, please be patient" efs-pkg)
1268       (declare-fboundp (curl:download (concat url efs-pkg)
1269                                       (expand-file-name efs-pkg dldir)))
1270       (message "Download complete.")
1271       ;; Install xemacs-base
1272       (if (equal (package-get-info 'xemacs-base 'md5sum)
1273                  (with-temp-buffer
1274                    (insert-file-contents-literally
1275                     (expand-file-name xemacs-base-pkg dldir))
1276                    (md5 (current-buffer))))
1277           (progn
1278             (package-admin-add-binary-package
1279              (expand-file-name xemacs-base-pkg dldir)
1280              (package-admin-get-install-dir 'xemacs-base))
1281             (push (file-name-as-directory
1282                    (expand-file-name "lisp/xemacs-base"
1283                                      (package-admin-get-install-dir 'xemacs-base)))
1284                   load-path)
1285             (load-file (expand-file-name "lisp/xemacs-base/_pkg.el"
1286                                          (package-admin-get-install-dir 'xemacs-base)))
1287             (load-file (expand-file-name "lisp/xemacs-base/auto-autoloads.el"
1288                                          (package-admin-get-install-dir 'xemacs-base)))
1289             (message "xemacs-base package installed"))
1290         (delete-file (expand-file-name xemacs-base-pkg dldir))
1291         (error "MD5 mismatch, %s deleted" (expand-file-name xemacs-base-pkg dldir)))
1292       ;; Install EFS
1293       (if (equal (package-get-info 'efs 'md5sum)
1294                  (with-temp-buffer
1295                    (insert-file-contents-literally
1296                     (expand-file-name efs-pkg dldir))
1297                    (md5 (current-buffer))))
1298           (progn
1299             (package-admin-add-binary-package
1300              (expand-file-name efs-pkg dldir)
1301              (package-admin-get-install-dir 'efs))
1302             (push (file-name-as-directory
1303                    (expand-file-name "lisp/efs"
1304                                      (package-admin-get-install-dir 'efs)))
1305                   load-path)
1306             (load-file (expand-file-name "lisp/efs/_pkg.el"
1307                                          (package-admin-get-install-dir 'efs)))
1308             (load-file (expand-file-name "lisp/efs/auto-autoloads.el"
1309                                          (package-admin-get-install-dir 'efs)))
1310             (message "efs package installed"))
1311         (delete-file (expand-file-name efs-pkg dldir))
1312         (error "MD5 mismatch, %s deleted" (expand-file-name efs-pkg dldir)))
1313       (when (y-or-n-p "Install more packages? ")
1314         (declare-fboundp (pui-list-packages))))))
1315
1316 (provide 'package-get)
1317
1318 ;; On-load forms
1319 (unless (and (featurep 'package-ui)
1320              (fboundp 'loop))
1321   (require 'package-ui)
1322   (load "cl-macs"))
1323
1324 ;;; package-get.el ends here