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 (define-widget 'url-scheme 'string
 191   "A URL protocol scheme."
 192   :tag "URL-Scheme")
 193
 194 (defcustom package-get-remote nil
 195   "*The remote site to contact for downloading packages.
 196
 197 Format is '(site-name directory-on-site scheme).  As a special case,
 198 `site-name' can be `nil', in which case `directory-on-site' is treated
 199 as a local directory."
 200   :tag "Package repository"
 201   :type '(set (choice (const :tag "None" nil)
 202                       (list :tag "Local" (const :tag "Local" nil) directory)
 203                       (list :tag "Remote" host-name directory url-scheme)))
 204   :group 'package-get)
 205
 206 (defvar package-get-have-curl (featurep 'ffi-curl)
 207   "Non-nil when FFI and curl is available.")
 208
 209 ;;;###autoload
 210 (defcustom package-get-download-sites
 211   `(,@(when package-get-have-curl
 212        '(("SXEmacs XE pkg mirror"
 213          "downloads.sxemacs.org" "xemacs-pkgs/packages" "http")))
 214     ("US (Main XEmacs Site)"
 215      "ftp.xemacs.org" "pub/xemacs/packages" "ftp")
 216     ;; In alphabetical order of Country, our mirrors...
 217     ("Belgium (be.xemacs.org)"
 218      "ftp.be.xemacs.org" "xemacs/packages" "ftp")
 219     ("Canada (ca.xemacs.org)"
 220      "ftp.ca.xemacs.org" "pub/Mirror/xemacs/packages" "ftp")
 221     ("Denmark (dk.xemacs.org)"
 222      "ftp.dk.xemacs.org" "xemacs/packages" "ftp")
 223     ("France (fr.xemacs.org)"
 224      "ftp.fr.xemacs.org" "pub/xemacs/packages" "ftp")
 225     ("France (mirror.cict.fr)"
 226      "mirror.cict.fr" "xemacs/packages" "ftp")
 227     ("France (pasteur.fr)"
 228      "ftp.pasteur.fr" "pub/computing/xemacs/packages" "ftp")
 229     ("Germany (de.xemacs.org)"
 230      "ftp.de.xemacs.org" "pub/ftp.xemacs.org/tux/xemacs/packages" "ftp")
 231     ("Greece (gr.xemacs.org)"
 232      "ftp.gr.xemacs.org" "mirrors/XEmacs/ftp/packages" "ftp")
 233     ("Ireland (heanet.ie)"
 234      "ftp.heanet.ie" "mirrors/ftp.xemacs.org/packages" "ftp")
 235     ("Italy (it.xemacs.org)"
 236      "ftp.it.xemacs.org" "unix/packages/XEMACS/packages" "ftp")
 237     ("Japan (dti.ad.jp)"
 238      "ftp.dti.ad.jp" "pub/unix/editor/xemacs/packages" "ftp")
 239     ("Norway (no.xemacs.org)"
 240      "ftp.no.xemacs.org" "pub/xemacs/packages" "ftp")
 241     ("Portugal (pt.xemacs.org)"
 242      "ftp.pt.xemacs.org" "pub/MIRRORS/ftp.xemacs.org/packages" "ftp")
 243     ("Saudi Arabia (sa.xemacs.org)"
 244      "ftp.sa.xemacs.org" "pub/xemacs.org/packages" "ftp")
 245     ("Sweden (se.xemacs.org)"
 246      "ftp.se.xemacs.org" "pub/gnu/xemacs/packages" "ftp")
 247     ("Switzerland (ch.xemacs.org)"
 248      "ftp.ch.xemacs.org" "mirror/xemacs/packages" "ftp")
 249     ("Taiwan (ftp.tw.xemacs.org)"
 250      "ftp.tw.xemacs.org" "Unix/Editors/XEmacs/packages" "ftp")
 251     ("UK (uk.xemacs.org)"
 252      "ftp.uk.xemacs.org" "sites/ftp.xemacs.org/pub/xemacs/packages" "ftp")
 253     ("US (ibiblio.org)"
 254      "mirrors.ibiblio.org" "pub/mirrors/xemacs/packages" "ftp")
 255     )
 256   "*List of remote sites available for downloading packages.
 257
 258 List format is '(site-description site-name directory-on-site url-scheme).
 259 SITE-DESCRIPTION is a textual description of the site.  SITE-NAME is
 260 the internet address of the download site.  DIRECTORY-ON-SITE is the
 261 directory on the site in which packages may be found.  URL-SCHEME is
 262 the protocol such as `http', `ftp', etc.  This variable is used to
 263 initialize `package-get-remote', the variable actually used to specify
 264 package download sites."
 265   :tag "Package download sites"
 266   :type '(repeat (list (string :tag "Name")
 267                        host-name directory url-scheme))
 268   :group 'package-get)
 269
 270 ;;; Dead Sites (normal release)
 271     ; Unknown host
 272     ;("Argentina (xmundo.net)" "xemacs.xmundo.net" "pub/mirrors/xemacs/packages")
 273     ; No longer carries XEmacs releases or packages
 274     ;("Australia (aarnet.edu.au)" "mirror.aarnet.edu.au" "pub/xemacs/packages")
 275     ; Unknown host
 276     ;("Australia (au.xemacs.org)" "ftp.au.xemacs.org" "pub/xemacs/packages")
 277     ; No longer carries XEmacs releases or packages
 278     ;("Austria (at.xemacs.org)" "ftp.at.xemacs.org" "editors/xemacs/packages")
 279     ; No longer carries XEmacs releases or packages
 280     ;("Brazil (br.xemacs.org)" "ftp.br.xemacs.org" "pub/xemacs/packages")
 281     ; Connection problems, can't list in either passive or not
 282     ;("Canada (nrc.ca)" "ftp.nrc.ca" "pub/packages/editors/xemacs/packages")
 283     ;; no anonymous ftp available, uncomment when updating website
 284     ;; with
 285     ;; xemacs-builds/adrian/website/package-get-2-download-sites.el
 286 ;     ("Chile (cl.xemacs.org)" "ftp.cl.xemacs.org" "packages")
 287     ; Unknown host
 288     ;("China (ftp.cn.xemacs.org)" "ftp.cn.xemacs.org" "pub/xemacs/packages")
 289     ; XEmacs directory exists, but is empty
 290     ;("Czech Republic (cz.xemacs.org)" "ftp.cz.xemacs.org" "MIRRORS/ftp.xemacs.org/pub/xemacs/packages")
 291     ; Exists, but is 3 years out of date
 292     ;("Finland (fi.xemacs.org)" "ftp.fi.xemacs.org" "pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/packages")
 293     ; Site exists, but has no content
 294     ;("Hong Kong (hk.xemacs.org)" "ftp.hk.xemacs.org" "pub/xemacsftp/packages")
 295     ; Can't connect, times out.
 296     ;("Ireland (ie.xemacs.org)" "ftp.ie.xemacs.org" "mirrors/ftp.xemacs.org/pub/xemacs/packages")
 297 ;   ("Japan (jaist.ac.jp)" "ftp.jaist.ac.jp" "pub/GNU/xemacs/packages")
 298     ; Unknown host
 299     ;("Japan (jp.xemacs.org)" "ftp.jp.xemacs.org" "pub/text/xemacs/packages")
 300 ;   ("Japan (nucba.ac.jp)" "mirror.nucba.ac.jp" "mirror/xemacs/packages")
 301     ; Can't connect, times out.
 302     ;("Korea (kr.xemacs.org)" "ftp.kr.xemacs.org" "pub/tools/emacs/xemacs/packages")
 303     ; No anonymous ftp available
 304     ;("Netherlands (nl.xemacs.org)" "ftp.nl.xemacs.org" "pub/xemacs/ftp/packages")
 305     ;; no anonymous ftp available, uncomment when updating website
 306     ;; with
 307     ;; xemacs-builds/adrian/website/package-get-2-download-sites.el
 308 ;     ("Netherlands (xemacsftp.digimirror.nl)" "xemacsftp.digimirror.nl" "packages")
 309     ; Times out
 310     ;("Russia (ru.xemacs.org)" "ftp.ru.xemacs.org" "pub/emacs/xemacs/packages")
 311     ; Unknown host
 312     ;("US (us.xemacs.org)" "ftp.us.xemacs.org" "pub/mirrors/xemacs/packages")
 313
 314 ;;;###autoload
 315 (defcustom package-get-pre-release-download-sites
 316   `(,@(when package-get-have-curl
 317        '(("SXEmacs XE pkg Pre-Releases" "downloads.sxemacs.org"
 318           "xemacs-pkgs/beta/experimental/packages" "http")))
 319     ("US Pre-Releases (Main XEmacs Site)" "ftp.xemacs.org"
 320      "pub/xemacs/beta/experimental/packages" "ftp")
 321     ;; In alphabetical order of Country, our mirrors...
 322     ("Belgium Pre-Releases (be.xemacs.org)" "ftp.be.xemacs.org"
 323      "xemacs/beta/experimental/packages" "ftp")
 324     ("Canada Pre-Releases (ca.xemacs.org)" "ftp.ca.xemacs.org"
 325      "pub/Mirror/xemacs/beta/experimental/packages" "ftp")
 326     ("Denmark Pre-Releases (dk.xemacs.org)" "ftp.dk.xemacs.org"
 327      "xemacs/beta/experimental/packages" "ftp")
 328     ("France Pre-Releases (fr.xemacs.org)" "ftp.fr.xemacs.org"
 329      "pub/xemacs/beta/experimental/packages" "ftp")
 330     ; Was a month out of date as of 2013-04-12, hopefully not a sign
 331     ; it is no longer updating.
 332     ("France Pre-Releases (mirror.cict.fr)" "mirror.cict.fr"
 333      "xemacs/beta/experimental/packages" "ftp")
 334     ("France Pre-Releases (pasteur.fr)" "ftp.pasteur.fr"
 335      "pub/computing/xemacs/beta/experimental/packages" "ftp")
 336     ("Germany Pre-Releases (de.xemacs.org)" "ftp.de.xemacs.org"
 337      "pub/ftp.xemacs.org/tux/xemacs/beta/experimental/packages" "ftp")
 338     ("Greece Pre-Releases (gr.xemacs.org)" "ftp.gr.xemacs.org"
 339      "mirrors/XEmacs/ftp/beta/experimental/packages" "ftp")
 340     ("Ireland Pre-Releases (heanet.ie)" "ftp.heanet.ie"
 341      "mirrors/ftp.xemacs.org/beta/experimental/packages" "ftp")
 342     ("Italy Pre-Releases (it.xemacs.org)" "ftp.it.xemacs.org"
 343      "unix/packages/XEMACS/beta/experimental/packages" "ftp")
 344     ; Was out of date as at 2013-04-12.  Hopefully not a sign they are
 345     ; no longer updating.
 346     ("Japan Pre-Releases (dti.ad.jp)" "ftp.dti.ad.jp"
 347      "pub/unix/editor/xemacs/beta/experimental/packages" "ftp")
 348     ("Norway Pre-Releases (no.xemacs.org)" "ftp.no.xemacs.org"
 349      "pub/xemacs/beta/experimental/packages" "ftp")
 350     ("Portugal Pre-Releases (pt.xemacs.org)" "ftp.pt.xemacs.org"
 351      "pub/MIRRORS/ftp.xemacs.org/beta/experimental/packages" "ftp")
 352     ("Saudi Arabia Pre-Releases (sa.xemacs.org)" "ftp.sa.xemacs.org"
 353      "pub/xemacs.org/beta/experimental/packages" "ftp")
 354     ("Sweden Pre-Releases (se.xemacs.org)" "ftp.se.xemacs.org"
 355      "pub/gnu/xemacs/beta/experimental/packages" "ftp")
 356     ("Switzerland Pre-Releases (ch.xemacs.org)" "ftp.ch.xemacs.org"
 357      "mirror/xemacs/beta/experimental/packages" "ftp")
 358     ("Taiwan Pre-Releases (ftp.tw.xemacs.org)" "ftp.tw.xemacs.org"
 359      "Unix/Editors/XEmacs/beta/experimental/packages" "ftp")
 360     ("UK Pre-Releases (uk.xemacs.org)" "ftp.uk.xemacs.org"
 361      "sites/ftp.xemacs.org/pub/xemacs/beta/experimental/packages" "ftp")
 362     ("US Pre-Releases (ibiblio.org)" "mirrors.ibiblio.org"
 363      "pub/mirrors/xemacs/beta/experimental/packages" "ftp")
 364     )
 365   "*List of remote sites available for downloading \"Pre-Release\" packages.
 366
 367 List format is '(site-description site-name directory-on-site url-scheme).
 368 SITE-DESCRIPTION is a textual description of the site.  SITE-NAME is
 369 the internet address of the download site.  DIRECTORY-ON-SITE is the
 370 directory on the site in which packages may be found.  URL-SCHEME is
 371 the protocol such as `http', `ftp', etc.  This variable is used to
 372 initialize `package-get-remote', the variable actually used to specify
 373 package download sites."
 374   :tag "Pre-Release Package download sites"
 375   :type '(repeat (list (string :tag "Name")
 376                        host-name directory url-scheme))
 377   :group 'package-get)
 378
 379 ;;; Dead sites (pre-release)
 380     ; Unknown host
 381     ;("Argentina Pre-Releases (xmundo.net)" "xemacs.xmundo.net"
 382     ; "pub/mirrors/xemacs/beta/experimental/packages")
 383     ; No longer carries XEmacs releases or packages
 384     ;("Australia Pre-Releases (aarnet.edu.au)" "mirror.aarnet.edu.au"
 385     ; "pub/xemacs/beta/experimental/packages")
 386     ; Unknown host
 387     ;("Australia Pre-Releases (au.xemacs.org)" "ftp.au.xemacs.org"
 388     ; "pub/xemacs/beta/experimental/packages")
 389     ; No longer carries XEmacs releases or packages
 390     ;("Austria Pre-Releases (at.xemacs.org)" "ftp.at.xemacs.org"
 391     ; "editors/xemacs/beta/experimental/packages")
 392     ; No longer carries XEmacs releases or packages
 393     ;("Brazil Pre-Releases (br.xemacs.org)" "ftp.br.xemacs.org"
 394     ; "pub/xemacs/xemacs-21.5/experimental/packages")
 395     ; Connection problems, can't list in either passive or not
 396     ;("Canada Pre-Releases (nrc.ca)" "ftp.nrc.ca"
 397     ; "pub/packages/editors/xemacs/beta/experimental/packages")
 398     ;; no anonymous ftp available, uncomment when updating website
 399     ;; with
 400     ;; xemacs-builds/adrian/website/package-get-2-download-sites.el
 401 ;     ("Chile Pre-Releases (cl.xemacs.org)" "ftp.cl.xemacs.org"
 402 ;      "beta/experimental/packages")
 403     ; Unknown host
 404     ;("China Pre-Releases (ftp.cn.xemacs.org)" "ftp.cn.xemacs.org"
 405     ; "pub/xemacs/beta/experimental/packages")
 406     ; XEmacs directory exists, but is empty
 407     ;("Czech Republic Pre-Releases (cz.xemacs.org)" "ftp.cz.xemacs.org"
 408     ; "MIRRORS/ftp.xemacs.org/pub/xemacs/xemacs-21.5/experimental/packages")
 409     ; Exists, but is 3 years out of date
 410     ;("Finland Pre-Releases (fi.xemacs.org)" "ftp.fi.xemacs.org"
 411     ; "pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/beta/experimental/packages")
 412     ; Site exists, but has no content
 413     ;("Hong Kong Pre-Releases (hk.xemacs.org)" "ftp.hk.xemacs.org"
 414     ; "pub/xemacsftp/beta/experimental/packages")
 415     ; Can't connect, times out.
 416     ;("Ireland Pre-Releases (ie.xemacs.org)" "ftp.ie.xemacs.org"
 417     ; "mirrors/ftp.xemacs.org/pub/xemacs/beta/experimental/packages")
 418 ;   ("Japan Pre-Releases (jaist.ac.jp)" "ftp.jaist.ac.jp"
 419 ;    "pub/GNU/xemacs/beta/experimental/packages")
 420     ; Unknown host
 421     ;("Japan Pre-Releases (jp.xemacs.org)" "ftp.jp.xemacs.org"
 422     ; "pub/text/xemacs/beta/experimental/packages")
 423     ; Can't connect, times out.
 424     ;("Korea Pre-Releases (kr.xemacs.org)" "ftp.kr.xemacs.org"
 425     ; "pub/tools/emacs/xemacs/beta/experimental/packages")
 426     ; No anonymous ftp available
 427     ;("Netherlands Pre-Releases (nl.xemacs.org)" "ftp.nl.xemacs.org"
 428     ; "pub/xemacs/ftp/beta/experimental/packages")
 429     ;; no anonymous ftp available, uncomment when updating website
 430     ;; with
 431     ;; xemacs-builds/adrian/website/package-get-2-download-sites.el
 432 ;     ("Netherlands Pre-Releases (xemacsftp.digimirror.nl)" "xemacsftp.digimirror.nl"
 433 ;      "beta/experimental/packages")
 434     ; Times out
 435     ;("Russia Pre-Releases (ru.xemacs.org)" "ftp.ru.xemacs.org"
 436     ; "pub/emacs/xemacs/beta/experimental/packages")
 437     ; Unknown host
 438     ;("US Pre-Releases (us.xemacs.org)" "ftp.us.xemacs.org"
 439     ; "pub/mirrors/xemacs/beta/experimental/packages")
 440
 441
 442 ;;;###autoload
 443 (defcustom package-get-site-release-download-sites nil
 444   "*List of remote sites available for downloading \"Site Release\" packages.
 445
 446 List format is '(site-description site-name directory-on-site url-scheme).
 447 SITE-DESCRIPTION is a textual description of the site.  SITE-NAME is
 448 the internet address of the download site.  DIRECTORY-ON-SITE is the
 449 directory on the site in which packages may be found.  URL-SCHEME is
 450 the protocol such as `http', `ftp', etc.  This variable is used to
 451 initialize `package-get-remote', the variable actually used to specify
 452 package download sites."
 453   :tag "Site Release Package download sites"
 454   :type '(repeat (list (string :tag "Name")
 455                        host-name directory url-scheme))
 456   :group 'package-get)
 457
 458 (defcustom package-get-remove-copy t
 459   "*After copying and installing a package, if this is t, then remove the
 460 copy.  Otherwise, keep it around."
 461   :type 'boolean
 462   :group 'package-get)
 463
 464 ;; #### it may make sense for this to be a list of names.
 465 ;; #### also, should we rename "*base*" to "*index*" or "*db*"?
 466 ;;      "base" is a pretty poor name.
 467 (defcustom package-get-base-filename "package-index.LATEST.gpg"
 468   "*Name of the default package-get database file.
 469 This may either be a relative path, in which case it is interpreted
 470 with respect to `package-get-remote', or an absolute path."
 471   :type 'file
 472   :group 'package-get)
 473
 474 (defcustom package-get-always-update nil
 475   "*If Non-nil always make sure we are using the latest package index (base).
 476 Otherwise respect the `force-current' argument of `package-get-require-base'."
 477   :type 'boolean
 478   :group 'package-get)
 479
 480 (defvar package-get-was-current nil
 481   "Non-nil we did our best to fetch a current database.")
 482
 483 ;;;###autoload
 484 (defun package-get-require-base (&optional force-current)
 485   "Require that a package-get database has been loaded.
 486 If the optional FORCE-CURRENT argument or the value of
 487 `package-get-always-update' is Non-nil, try to update the database
 488 from a location in `package-get-remote'. Otherwise a local copy is used
 489 if available and remote access is never done.
 490
 491 Please use FORCE-CURRENT only when the user is explictly dealing with packages
 492 and remote access is likely in the near future."
 493   (setq force-current (or force-current package-get-always-update))
 494   (unless (and (boundp 'package-get-base)
 495                package-get-base
 496                (or (not force-current) package-get-was-current))
 497     (package-get-update-base nil force-current))
 498   (if (or (not (boundp 'package-get-base))
 499           (not package-get-base))
 500       (error 'void-variable
 501              "Package-get database not loaded")
 502     (setq package-get-was-current force-current)))
 503
 504 ;;;###autoload
 505 (defun package-get-update-base-entry (entry)
 506   "Update an entry in `package-get-base'."
 507   (let ((existing (assq (car entry) package-get-base)))
 508     (if existing
 509         (setcdr existing (cdr entry))
 510       (setq package-get-base (cons entry package-get-base)))))
 511
 512 (defun package-get-locate-file (file &optional nil-if-not-found no-remote)
 513   "Locate an existing FILE with respect to `package-get-remote'.
 514 If FILE is an absolute path or is not found, simply return FILE.
 515 If optional argument NIL-IF-NOT-FOUND is non-nil, return nil
 516 if FILE can not be located.
 517 If NO-REMOTE is non-nil never search remote locations."
 518   (if (file-name-absolute-p file)
 519       file
 520     (let ((site package-get-remote)
 521           (expanded nil))
 522       (when site
 523         (unless (and no-remote (caar (list site)))
 524           (let ((expn (package-get-remote-filename (car (list site)) file)))
 525             (if (and expn (file-exists-p expn))
 526                 (setq site nil
 527                       expanded expn)))))
 528       (or expanded
 529           (and (not nil-if-not-found)
 530                file)))))
 531
 532 (defun package-get-locate-index-file (no-remote)
 533   "Locate the package-get index file.
 534
 535 Do not return remote paths if NO-REMOTE is non-nil.  If the index
 536 file doesn't exist in `package-get-package-index-file-location', ask
 537 the user if one should be created using the index file in core as a
 538 template."
 539   (or (package-get-locate-file package-get-base-filename t no-remote)
 540       (if (file-exists-p (expand-file-name package-get-base-filename
 541                                            package-get-package-index-file-location))
 542           (expand-file-name package-get-base-filename
 543                             package-get-package-index-file-location)
 544         (if (y-or-n-p (format "No index file, shall I create one in %s? "
 545                               package-get-package-index-file-location))
 546             (progn
 547               (save-excursion
 548                 (set-buffer
 549                  (find-file-noselect (expand-file-name
 550                                       package-get-base-filename
 551                                       package-get-package-index-file-location)))
 552                 (let ((coding-system-for-write 'binary))
 553                   (erase-buffer)
 554                   (insert-file-contents-literally
 555                    (locate-data-file package-get-base-filename))
 556                   (save-buffer (current-buffer))
 557                   (kill-buffer (current-buffer))))
 558               (expand-file-name package-get-base-filename
 559                                 package-get-package-index-file-location))
 560           (error 'search-failed
 561                  "Can't locate a package index file.")))))
 562
 563 (defun package-get-maybe-save-index (filename)
 564   "Offer to save the current buffer as the local package index file,
 565 if different."
 566   (let ((location (package-get-locate-index-file t)))
 567     (unless (and filename (equal filename location))
 568       (unless (and location
 569                    (equal (md5 (current-buffer))
 570                           (with-temp-buffer
 571                             (insert-file-contents-literally location)
 572                             (md5 (current-buffer)))))
 573         (when (not (file-writable-p location))
 574           (if (y-or-n-p (format "Sorry, %s is read-only, can I use %s? "
 575                                 location user-packages-topdir))
 576               (setq location (expand-file-name
 577                               package-get-base-filename
 578                               package-get-package-index-file-location))
 579             (error 'file-error
 580                    (format "%s is read-only" location))))
 581         (when (y-or-n-p (concat "Update package index in " location "? "))
 582           (let ((coding-system-for-write 'binary))
 583             (write-file location)))))))
 584
 585 ;;;###autoload
 586 (defun package-get-update-base (&optional db-file force-current)
 587   "Update the package-get database file with entries from DB-FILE.
 588 Unless FORCE-CURRENT is non-nil never try to update the database."
 589   (interactive
 590    (let ((dflt (package-get-locate-index-file nil)))
 591      (list (read-file-name "Load package-get database: "
 592                            (file-name-directory dflt)
 593                            dflt
 594                            t
 595                            (file-name-nondirectory dflt)))))
 596   (setq db-file (expand-file-name (or db-file
 597                                       (package-get-locate-index-file
 598                                          (not force-current)))))
 599   (if (not (file-exists-p db-file))
 600       (error 'file-error
 601              (format "Package-get database file `%s' does not exist" db-file)))
 602   (if (not (file-readable-p db-file))
 603       (error 'file-error
 604              (format "Package-get database file `%s' not readable" db-file)))
 605   (let ((buf (get-buffer-create "*package database*")))
 606     (unwind-protect
 607         (save-excursion
 608           (set-buffer buf)
 609           (erase-buffer buf)
 610           (insert-file-contents-literally db-file)
 611           (package-get-update-base-from-buffer buf)
 612           (if (file-remote-p db-file)
 613               (package-get-maybe-save-index db-file)))
 614       (kill-buffer buf))))
 615
 616 ;; This is here because the `process-error' datum doesn't exist in
 617 ;; 21.4. --SY.
 618 (define-error 'process-error "Process error")
 619
 620 ;;;###autoload
 621 (defun package-get-update-base-from-buffer (&optional buf)
 622   "Update the package-get database with entries from BUFFER.
 623 BUFFER defaults to the current buffer.  This command can be
 624 used interactively, for example from a mail or news buffer."
 625   (interactive)
 626   (setq buf (or buf (current-buffer)))
 627   (let ((coding-system-for-read 'binary)
 628         (coding-system-for-write 'binary)
 629         content-beg content-end)
 630     (save-excursion
 631       (set-buffer buf)
 632       (goto-char (point-min))
 633       (setq content-beg (point))
 634       (setq content-end (save-excursion (goto-char (point-max)) (point)))
 635       (package-get-update-base-entries content-beg content-end)
 636       (message "Updated package database"))))
 637
 638 (defun package-get-update-base-entries (start end)
 639   "Update the package-get database with the entries found between
 640 START and END in the current buffer."
 641   (save-excursion
 642     (goto-char start)
 643     (if (not (re-search-forward "^(package-get-update-base-entry" nil t))
 644         (error 'search-failed
 645                "Buffer does not contain package-get database entries"))
 646     (beginning-of-line)
 647     (let ((count 0))
 648       (while (and (< (point) end)
 649                   (re-search-forward "^(package-get-update-base-entry" nil t))
 650         (beginning-of-line)
 651         (let ((entry (read (current-buffer))))
 652           (if (or (not (consp entry))
 653                   (not (eq (car entry) 'package-get-update-base-entry)))
 654               (error 'syntax-error
 655                      "Invalid package-get database entry found"))
 656           (package-get-update-base-entry
 657            (car (cdr (car (cdr entry)))))
 658           (setq count (1+ count))))
 659       (message "Got %d package-get database entries" count))))
 660
 661 ;;;###autoload
 662 (defun package-get-save-base (file)
 663   "Write the package-get database to FILE.
 664
 665 Note: This database will be unsigned of course."
 666   (interactive "FSave package-get database to: ")
 667   (package-get-require-base t)
 668   (let ((buf (get-buffer-create "*package database*")))
 669     (unwind-protect
 670         (save-excursion
 671           (set-buffer buf)
 672           (erase-buffer buf)
 673           (goto-char (point-min))
 674           (let ((entries package-get-base) entry plist)
 675             (insert ";; Package Index file -- Do not edit manually.\n")
 676             (insert ";;;@@@\n")
 677             (while entries
 678               (setq entry (car entries))
 679               (setq plist (car (cdr entry)))
 680               (insert "(package-get-update-base-entry (quote\n")
 681               (insert (format "(%s\n" (symbol-name (car entry))))
 682               (while plist
 683                 (insert (format "  %s%s %S\n"
 684                                 (if (eq plist (car (cdr entry))) "(" " ")
 685                                 (symbol-name (car plist))
 686                                 (car (cdr plist))))
 687                 (setq plist (cdr (cdr plist))))
 688               (insert "))\n))\n;;;@@@\n")
 689               (setq entries (cdr entries))))
 690           (insert ";; Package Index file ends here\n")
 691           (write-region (point-min) (point-max) file))
 692       (kill-buffer buf))))
 693
 694 (defun package-get-interactive-package-query (get-version package-symbol)
 695   "Perform interactive querying for package and optional version.
 696 Query for a version if GET-VERSION is non-nil.  Return package name as
 697 a symbol instead of a string if PACKAGE-SYMBOL is non-nil.
 698 The return value is suitable for direct passing to `interactive'."
 699   (package-get-require-base t)
 700   (let ((table (mapcar #'(lambda (item)
 701                            (let ((name (symbol-name (car item))))
 702                              (cons name name)))
 703                        package-get-base))
 704         package package-symbol default-version version)
 705     (save-window-excursion
 706       (setq package (completing-read "Package: " table nil t))
 707       (setq package-symbol (intern package))
 708       (if get-version
 709           (progn
 710             (setq default-version
 711                   (package-get-info-prop
 712                    (package-get-info-version
 713                     (package-get-info-find-package package-get-base
 714                                                    package-symbol) nil)
 715                    'version))
 716             (while (string=
 717                     (setq version (read-string "Version: " default-version))
 718                     ""))
 719             (if package-symbol
 720                 (list package-symbol version)
 721               (list package version)))
 722         (if package-symbol
 723             (list package-symbol)
 724           (list package))))))
 725
 726 ;;;###autoload
 727 (defun package-get-delete-package (package &optional pkg-topdir)
 728   "Delete an installation of PACKAGE below directory PKG-TOPDIR.
 729 PACKAGE is a symbol, not a string.
 730 This is just an interactive wrapper for `package-admin-delete-binary-package'."
 731   (interactive (package-get-interactive-package-query nil t))
 732   (package-admin-delete-binary-package package pkg-topdir))
 733
 734 ;;;###autoload
 735 (defun package-get-update-all ()
 736   "Fetch and install the latest versions of all currently installed packages."
 737   (interactive)
 738   (package-get-require-base t)
 739   ;; Load a fresh copy
 740   (catch 'exit
 741     (mapcar (lambda (pkg)
 742               (if (not (package-get (car pkg) nil 'never))
 743                   (throw 'exit nil)))           ;; Bail out if error detected
 744             packages-package-list)))
 745
 746 ;;;###autoload
 747 (defun package-get-all (package version &optional fetched-packages install-dir)
 748   "Fetch PACKAGE with VERSION and all other required packages.
 749 Uses `package-get-base' to determine just what is required and what
 750 package provides that functionality.  If VERSION is nil, retrieves
 751 latest version.  Optional argument FETCHED-PACKAGES is used to keep
 752 track of packages already fetched.  Optional argument INSTALL-DIR,
 753 if non-nil, specifies the package directory where fetched packages
 754 should be installed.
 755
 756 Returns nil upon error."
 757   (interactive (package-get-interactive-package-query t nil))
 758   (let* ((the-package (package-get-info-find-package package-get-base
 759                                                      package))
 760          (this-package (package-get-info-version
 761                         the-package version))
 762          (this-requires (package-get-info-prop this-package 'requires)))
 763     (catch 'exit
 764       (setq version (package-get-info-prop this-package 'version))
 765       (unless (package-get-installedp package version)
 766         (if (not (package-get package version nil install-dir))
 767             (progn
 768               (setq fetched-packages nil)
 769               (throw 'exit nil))))
 770       (setq fetched-packages
 771             (append (list package)
 772                     (package-get-info-prop this-package 'provides)
 773                     fetched-packages))
 774       ;; grab everything that this package requires plus recursively
 775       ;; grab everything that the requires require.  Keep track
 776       ;; in `fetched-packages' the list of things provided -- this
 777       ;; keeps us from going into a loop
 778       (while this-requires
 779         (if (not (member (car this-requires) fetched-packages))
 780             (let* ((reqd-package (package-get-package-provider
 781                                   (car this-requires) t))
 782                    (reqd-version (cadr reqd-package))
 783                    (reqd-name (car reqd-package)))
 784               (if (null reqd-name)
 785                   (error 'search-failed
 786                          (format "Unable to find a provider for %s"
 787                                  (car this-requires))))
 788               (if (not (setq fetched-packages
 789                              (package-get-all reqd-name reqd-version
 790                                               fetched-packages
 791                                               install-dir)))
 792                   (throw 'exit nil))))
 793         (setq this-requires (cdr this-requires))))
 794     fetched-packages))
 795
 796 ;;;###autoload
 797 (defun package-get-dependencies (packages)
 798   "Compute dependencies for PACKAGES.
 799 Uses `package-get-base' to determine just what is required and what
 800 package provides that functionality.  Returns the list of packages
 801 required by PACKAGES."
 802   (package-get-require-base t)
 803   (let ((orig-packages packages)
 804         dependencies provided)
 805     (while packages
 806       (let* ((package (car packages))
 807              (the-package (package-get-info-find-package
 808                            package-get-base package))
 809              (this-package (package-get-info-version
 810                             the-package nil))
 811              (this-requires (package-get-info-prop this-package 'requires))
 812              (new-depends   (set-difference
 813                              (mapcar
 814                               #'(lambda (reqd)
 815                                   (let* ((reqd-package (package-get-package-provider reqd))
 816                                          (reqd-name    (car reqd-package)))
 817                                     (if (null reqd-name)
 818                                         (error 'search-failed
 819                                                (format "Unable to find a provider for %s" reqd)))
 820                                     reqd-name))
 821                               this-requires)
 822                              dependencies))
 823              (this-provides (package-get-info-prop this-package 'provides)))
 824         (setq dependencies
 825               (union dependencies new-depends))
 826         (setq provided
 827               (union provided (union (list package) this-provides)))
 828         (setq packages
 829               (union new-depends (cdr packages)))))
 830     (set-difference dependencies orig-packages)))
 831
 832 (defun package-get-load-package-file (lispdir file)
 833   (let (pathname)
 834     (setq pathname (expand-file-name file lispdir))
 835     (condition-case err
 836         (progn
 837           (load pathname t)
 838           t)
 839       (t
 840        (message "Error loading package file \"%s\" %s!" pathname err)
 841        nil))
 842     ))
 843
 844 (defun package-get-init-package (lispdir)
 845   "Initialize the package.
 846 This really assumes that the package has never been loaded.  Updating
 847 a newer package can cause problems, due to old, obsolete functions in
 848 the old package.
 849
 850 Return `t' upon complete success, `nil' if any errors occurred."
 851   (progn
 852     (if (and lispdir
 853              (file-accessible-directory-p lispdir))
 854         (progn
 855           ;; Add lispdir to load-path if it doesn't already exist.
 856           ;; NOTE: this does not take symlinks, etc., into account.
 857           (if (let ((dirs load-path))
 858                 (catch 'done
 859                   (while dirs
 860                     (if (string-equal (car dirs) lispdir)
 861                         (throw 'done nil))
 862                     (setq dirs (cdr dirs)))
 863                   t))
 864               (setq load-path (cons lispdir load-path)))
 865           (if (not (package-get-load-package-file lispdir "auto-autoloads"))
 866               (package-get-load-package-file lispdir "_pkg"))
 867           t)
 868       nil)))
 869
 870 ;;;###autoload
 871 (defun package-get-info (package information &optional arg remote)
 872   "Get information about a package.
 873
 874 Quite similar to `package-get-info-prop', but can retrieve a lot more
 875 information.
 876
 877 Argument PACKAGE is the name of an XEmacs package (a symbol).  It must
 878 be a valid package, ie, a member of `package-get-base'.
 879
 880 Argument INFORMATION is a symbol that can be any one of:
 881
 882    standards-version     Package system version (not used).
 883    version               Version of the XEmacs package.
 884    author-version        The upstream version of the package.
 885    date                  The date the package was last modified.
 886    build-date            The date the package was last built.
 887    maintainer            The maintainer of the package.
 888    distribution          Will always be \"xemacs\" (not used).
 889    priority              \"low\", \"medium\", or \"high\" (not used).
 890    category              Either \"standard\", \"mule\", or \"unsupported\"..
 891    dump                  Is the package dumped (not used).
 892    description           A description of the package.
 893    filename              The filename of the binary tarball of the package.
 894    md5sum                The md5sum of filename.
 895    size                  The size in bytes of filename.
 896    provides              A list of symbols that this package provides.
 897    requires              A list of packages that this package requires.
 898    type                  Can be either \"regular\" or \"single-file\".
 899
 900 If optional argument ARG is non-nil insert INFORMATION into current
 901 buffer at point.  This is very useful for doing things like inserting
 902 a maintainer's email address into a mail buffer.
 903
 904 If optional argument REMOTE is non-nil use a package list from a
 905 remote site.  For this to work `package-get-remote' must be non-nil.
 906
 907 If this function is called interactively it will display INFORMATION
 908 in the minibuffer."
 909   (interactive "SPackage: \nSInfo: \nP")
 910     (if remote
 911         (package-get-require-base t)
 912       (package-get-require-base nil))
 913     (let ((all-pkgs package-get-base)
 914           info)
 915       (loop until (equal package (caar all-pkgs))
 916         do (setq all-pkgs (cdr all-pkgs))
 917         do (if (not all-pkgs)
 918                (error 'invalid-argument
 919                       (format "%s is not a valid package" package))))
 920       (setq info (plist-get (cadar all-pkgs) information))
 921       (if (interactive-p)
 922           (if arg
 923               (insert (format "%s" info))
 924             (if (package-get-key package :version)
 925                 (message "%s" info)
 926               (message "%s (Package: %s is not installed)" info package)))
 927         (if arg
 928             (insert (format "%s" info))
 929           info))))
 930
 931 ;;;###autoload
 932 (defun package-get-list-packages-where (item field &optional arg)
 933   "Return a list of packages that fulfill certain criteria.
 934
 935 Argument ITEM, a symbol, is what you want to check for.  ITEM must be a
 936 symbol even when it doesn't make sense to be a symbol \(think, searching
 937 maintainers, descriptions, etc\).  The function will convert the symbol
 938 to a string if a string is what is needed.  The downside to this is that
 939 ITEM can only ever be a single word.
 940
 941 Argument FIELD, a symbol, is the field to check in.  You can specify
 942 any one of:
 943
 944       Field            Sane or Allowable Content
 945     description          any single word
 946     category             `standard' or `mule'
 947     maintainer           any single word
 948     build-date           yyyy-mm-dd
 949     date                 yyyy-mm-dd
 950     type                 `regular' or `single'
 951     requires             any package name
 952     provides             any symbol
 953     priority             `low', `medium', or `high'
 954
 955 Optional Argument ARG, a prefix arg, insert output at point in the
 956 current buffer."
 957   (interactive "SList packages that have (item): \nSin their (field): \nP")
 958   (package-get-require-base nil)
 959   (let ((pkgs package-get-base)
 960         (strings '(description category maintainer build-date date))
 961         (symbols '(type requires provides priority))
 962         results)
 963     (cond ((memq field strings)
 964            (setq item (symbol-name item))
 965            (while pkgs
 966              (when (string-match item (package-get-info (caar pkgs) field))
 967                (setq results (push (caar pkgs) results)))
 968              (setq pkgs (cdr pkgs))))
 969           ((memq field symbols)
 970            (if (or (eq field 'type)
 971                    (eq field 'priority))
 972                (while pkgs
 973                  (when (eq item (package-get-info (caar pkgs) field))
 974                    (setq results (push (caar pkgs) results)))
 975                  (setq pkgs (cdr pkgs)))
 976              (while pkgs
 977                (when (memq item (package-get-info (caar pkgs) field))
 978                  (setq results (push (caar pkgs) results)))
 979                (setq pkgs (cdr pkgs)))))
 980           (t
 981            (error 'wrong-type-argument field)))
 982     (if (interactive-p)
 983         (if arg
 984             (insert (format "%s" results))
 985           (message "%s" results)))
 986     results))
 987
 988 ;;;###autoload
 989 (defun package-get (package &optional version conflict install-dir)
 990   "Fetch PACKAGE from remote site.
 991 Optional arguments VERSION indicates which version to retrieve, nil
 992 means most recent version.  CONFLICT indicates what happens if the
 993 package is already installed.  Valid values for CONFLICT are:
 994 'always always retrieve the package even if it is already installed
 995 'never  do not retrieve the package if it is installed.
 996 INSTALL-DIR, if non-nil, specifies the package directory where
 997 fetched packages should be installed.
 998
 999 The value of `package-get-base' is used to determine what files should
1000 be retrieved.  The value of `package-get-remote' is used to determine
1001 where a package should be retrieved from.
1002
1003 Once the package is retrieved, its md5 checksum is computed.  If that
1004 sum does not match that stored in `package-get-base' for this version
1005 of the package, an error is signalled.
1006
1007 Returns `t' upon success, the symbol `error' if the package was
1008 successfully installed but errors occurred during initialization, or
1009 `nil' upon error."
1010   (interactive (package-get-interactive-package-query nil t))
1011   (catch 'skip-update
1012   (let* ((this-package
1013           (package-get-info-version
1014            (package-get-info-find-package package-get-base
1015                                           package) version))
1016          (latest (package-get-info-prop this-package 'version))
1017          (installed (package-get-key package :version))
1018          (found nil)
1019          (host nil)
1020          (search-dir package-get-remote)
1021          (base-filename (package-get-info-prop this-package 'filename))
1022          (package-status t)
1023          filenames full-package-filename)
1024     (if (and (equal (package-get-info package 'category) "mule")
1025              (not (featurep 'mule)))
1026         (error 'invalid-state
1027                "Mule packages can't be installed with a non-Mule SXEmacs"))
1028     (if (null this-package)
1029         (if package-get-remote
1030             (error 'search-failed
1031                    (format "Couldn't find package %s with version %s"
1032                            package version))
1033           (error 'syntax-error
1034                  "No download site or local package location specified.")))
1035     (if (null base-filename)
1036         (error 'syntax-error
1037                (format "No filename associated with package %s, version %s"
1038                        package version)))
1039     (setq install-dir (package-admin-get-install-dir package install-dir))
1040
1041     ;; If they asked for the latest using version=nil, don't get an older
1042     ;; version than we already have.
1043     (if installed
1044         (if (> (if (stringp installed)
1045                    (string-to-number installed)
1046                  installed)
1047                (if (stringp latest)
1048                    (string-to-number latest)
1049                  latest))
1050             (if (not (null version))
1051                 (warn "Installing %s package version %s, you had a newer version %s"
1052                   package latest installed)
1053               (warn "Skipping %s package, you have a newer version %s"
1054                 package installed)
1055               (throw 'skip-update t))))
1056
1057     ;; Contrive a list of possible package filenames.
1058     ;; Ugly.  Is there a better way to do this?
1059     (setq filenames (cons base-filename nil))
1060     (if (string-match #r"^\(..*\)\.tar\.gz$" base-filename)
1061         (setq filenames (append filenames
1062                                 (list (concat (match-string 1 base-filename)
1063                                               ".tgz")))))
1064
1065     (setq version latest)
1066     (unless (and (eq conflict 'never)
1067                  (package-get-installedp package version))
1068       ;; Find the package from the search list in package-get-remote
1069       ;; and copy it into the staging directory.  Then validate
1070       ;; the checksum.  Finally, install the package.
1071       (catch 'done
1072         (let (search-filenames dir current-filename dest-filename)
1073           ;; In each search directory ...
1074           (when search-dir
1075             (setq host (car search-dir)
1076                   dir (car (cdr search-dir))
1077                   search-filenames filenames)
1078
1079             ;; Look for one of the possible package filenames ...
1080             (while search-filenames
1081               (setq current-filename (car search-filenames)
1082                     dest-filename (package-get-staging-dir current-filename))
1083               (cond
1084                ;; No host means look on the current system.
1085                ((null host)
1086                 (setq full-package-filename
1087                       (substitute-in-file-name
1088                        (expand-file-name current-filename
1089                                          (file-name-as-directory dir)))))
1090
1091                ;; If it's already on the disk locally, and the size is
1092                ;; correct
1093                ((and (file-exists-p dest-filename)
1094                      (eq (nth 7 (file-attributes dest-filename))
1095                          (package-get-info package 'size)))
1096                  (setq full-package-filename dest-filename))
1097
1098                ;; Using EFS
1099                ;; If the file exists on the remote system ...
1100                ((and (not package-get-have-curl)
1101                      (file-exists-p (package-get-remote-filename
1102                                      search-dir current-filename)))
1103                 ;; Get it
1104                 (setq full-package-filename dest-filename)
1105                 (message "Retrieving package `%s' ..."
1106                          current-filename)
1107                 (sit-for 0)
1108                 (copy-file (package-get-remote-filename search-dir
1109                                                         current-filename)
1110                            full-package-filename t))
1111
1112                ;; Using ffi-curl
1113                (package-get-have-curl
1114                 (setq full-package-filename dest-filename)
1115                 (message "Retrieving package `%s' ..." current-filename)
1116                 (declare-fboundp
1117                  (curl:download (package-get-remote-filename search-dir
1118                                                              current-filename)
1119                                 full-package-filename))))
1120
1121               ;; If we found it, we're done.
1122               (if (and full-package-filename
1123                        (file-exists-p full-package-filename))
1124                   (throw 'done nil))
1125               ;; Didn't find it.  Try the next possible filename.
1126               (setq search-filenames (cdr search-filenames))))))
1127
1128       (if (or (not full-package-filename)
1129               (not (file-exists-p full-package-filename)))
1130           (if package-get-remote
1131               (error 'search-failed
1132                      (format "Unable to find file %s" base-filename))
1133             (error 'syntax-error
1134                    "No download sites or local package locations specified.")))
1135       ;; Validate the md5 checksum
1136       ;; Doing it with SXEmacs removes the need for an external md5 program
1137       (message "Validating checksum for `%s'..." package) (sit-for 0)
1138       (with-temp-buffer
1139         (insert-file-contents-literally full-package-filename)
1140         (if (not (string= (md5 (current-buffer))
1141                           (package-get-info-prop this-package
1142                                                  'md5sum)))
1143             (progn
1144               (unless (null host)
1145                 (delete-file full-package-filename))
1146               (error 'process-error
1147                      (format "Package %s does not match md5 checksum %s has been deleted"
1148                              base-filename full-package-filename)))))
1149
1150       (package-admin-delete-binary-package package install-dir)
1151
1152       (message "Installing package `%s' ..." package) (sit-for 0)
1153       (let ((status
1154              (package-admin-add-binary-package full-package-filename
1155                                                install-dir)))
1156         (if (= status 0)
1157             (progn
1158               ;; clear messages so that only messages from
1159               ;; package-get-init-package are seen, below.
1160               (clear-message)
1161               (if (package-get-init-package (package-admin-get-lispdir
1162                                              install-dir package))
1163                   (progn
1164                     (run-hook-with-args 'package-install-hook package install-dir)
1165                     (message "Added package `%s'" package)
1166                     (sit-for 0))
1167                 (progn
1168                   ;; display message only if there isn't already one.
1169                   (if (not (current-message))
1170                       (progn
1171                         (message "Added package `%s' (errors occurred)"
1172                                  package)
1173                         (sit-for 0)))
1174                   (if package-status
1175                       (setq package-status 'errors)))))
1176           (message "Installation of package %s failed." base-filename)
1177           (sit-for 0)
1178           (switch-to-buffer package-admin-temp-buffer)
1179           ;; null host means a local package mirror
1180           (unless (null host)
1181             (delete-file full-package-filename))
1182           (setq package-status nil)))
1183       (setq found t))
1184     (if (and found package-get-remove-copy (not (null host)))
1185         (delete-file full-package-filename))
1186     package-status)))
1187
1188 (defun package-get-info-find-package (which name)
1189   "Look in WHICH for the package called NAME and return all the info
1190 associated with it.  See `package-get-base' for info on the format
1191 returned.
1192
1193  To access fields returned from this, use
1194 `package-get-info-version' to return information about particular a
1195 version.  Use `package-get-info-find-prop' to find particular property
1196 from a version returned by `package-get-info-version'."
1197   (interactive "xPackage list: \nsPackage Name: ")
1198   (if which
1199       (if (eq (caar which) name)
1200           (cdar which)
1201         (if (cdr which)
1202             (package-get-info-find-package (cdr which) name)))))
1203
1204 (defun package-get-info-version (package version)
1205   "In PACKAGE, return the plist associated with a particular VERSION of the
1206   package.  PACKAGE is typically as returned by
1207   `package-get-info-find-package'.  If VERSION is nil, then return the
1208   first (aka most recent) version.  Use `package-get-info-find-prop'
1209   to retrieve a particular property from the value returned by this."
1210   (interactive (package-get-interactive-package-query t t))
1211   (while (and version package (not (string= (plist-get (car package) 'version) version)))
1212     (setq package (cdr package)))
1213   (if package (car package)))
1214
1215 (defun package-get-info-prop (package-version property)
1216   "In PACKAGE-VERSION, return the value associated with PROPERTY.
1217 PACKAGE-VERSION is typically returned by `package-get-info-version'
1218 and PROPERTY is typically (although not limited to) one of the
1219 following:
1220
1221 version         - version of this package
1222 provides                - list of symbols provided
1223 requires                - list of symbols that are required.
1224                   These in turn are provided by other packages.
1225 size            - size of the bundled package
1226 md5sum          - computed md5 checksum"
1227   (interactive "xPackage Version: \nSProperty")
1228   (plist-get package-version property))
1229
1230 (defun package-get-info-version-prop (package-list package version property)
1231   "In PACKAGE-LIST, search for PACKAGE with this VERSION and return
1232   PROPERTY value."
1233   (package-get-info-prop
1234    (package-get-info-version
1235     (package-get-info-find-package package-list package) version) property))
1236
1237 (defun package-get-staging-dir (filename)
1238   "Return a good place to stash FILENAME when it is retrieved.
1239 Use `package-get-dir' for directory to store stuff.
1240 Creates `package-get-dir'  if it doesn't exist."
1241   (interactive "FPackage filename: ")
1242   (if (not (file-exists-p package-get-dir))
1243       (make-directory package-get-dir))
1244   (expand-file-name
1245    (file-name-nondirectory (or (and-fboundp 'efs-ftp-path
1246                                  (nth 2 (efs-ftp-path filename)))
1247                                filename))
1248    (file-name-as-directory package-get-dir)))
1249
1250 (defun package-get-remote-filename (search filename)
1251   "Return FILENAME as a remote filename.
1252 It first checks if FILENAME already is a remote filename.  If it is
1253 not, then it uses the (car search) as the remote site-name and the (cadr
1254 search) as the remote-directory and concatenates filename.  In other
1255 words:
1256
1257         site-name:remote-directory/filename.
1258
1259 If ffi-curl has been loaded then this will return a URL style name,
1260 for example:
1261
1262         http://site-name/remote-directory/filename
1263
1264 The url scheme to use in this case is from (third search).
1265
1266 If (car search) is nil, (cadr search is interpreted as a local
1267 directory)."
1268   (if (file-remote-p filename)
1269       filename
1270     (let ((site (car search))
1271           (dir (cadr search))
1272           (scheme (third search)))
1273       (if (and site package-get-have-curl)
1274           (concat scheme "://" site "/" dir "/" filename)
1275         (concat (when site
1276                   (concat
1277                    (if (string-match "@" site)
1278                        "/"
1279                      "/anonymous@")
1280                    site ":"))
1281                 (if (string-match "/$" dir)
1282                     dir
1283                   (concat dir "/"))
1284                 filename)))))
1285
1286 (defun package-get-installedp (package version)
1287   "Determine if PACKAGE with VERSION has already been installed.
1288 I'm not sure if I want to do this by searching directories or checking
1289 some built in variables.  For now, use packages-package-list."
1290   ;; Use packages-package-list which contains name and version
1291   (equal (plist-get
1292           (package-get-info-find-package packages-package-list
1293                                          package) ':version)
1294          (if (floatp version)
1295              version
1296            (string-to-number version))))
1297
1298 ;;;###autoload
1299 (defun package-get-package-provider (sym &optional force-current)
1300   "Search for a package that provides SYM and return the name and
1301   version.  Searches in `package-get-base' for SYM.   If SYM is a
1302   consp, then it must match a corresponding (provide (SYM VERSION)) from
1303   the package.
1304
1305 If FORCE-CURRENT is non-nil make sure the database is up to date. This might
1306 lead to Emacs accessing remote sites."
1307   (interactive "SSymbol: ")
1308   (package-get-require-base force-current)
1309   (let ((packages package-get-base)
1310         (done nil)
1311         (found nil))
1312     (while (and (not done) packages)
1313       (let* ((this-name (caar packages))
1314              (this-package (cdr (car packages)))) ;strip off package name
1315         (while (and (not done) this-package)
1316           (if (or (eq this-name sym)
1317                   (eq (cons this-name
1318                           (package-get-info-prop (car this-package) 'version))
1319                       sym)
1320                   (member sym
1321                         (package-get-info-prop (car this-package) 'provides)))
1322               (progn (setq done t)
1323                      (setq found
1324                        (list (caar packages)
1325                          (package-get-info-prop (car this-package) 'version))))
1326             (setq this-package (cdr this-package)))))
1327       (setq packages (cdr packages)))
1328     (when (interactive-p)
1329       (if found
1330           (message "%S" found)
1331         (message "No appropriate package found")))
1332     found))
1333
1334 (defun package-get-ever-installed-p (pkg &optional notused)
1335   (string-match "-package$" (symbol-name pkg))
1336   (custom-initialize-set
1337    pkg
1338    (if (package-get-info-find-package
1339         packages-package-list
1340         (intern (substring (symbol-name pkg) 0 (match-beginning 0))))
1341        t)))
1342
1343 ;; This is obsolete now that #'package-get can use #'curl:download
1344 ;;(defun pui-bootstrap ()
1345 ;;  "Bootstrap the SXEmacs Package Tools.
1346
1347 ;;The Package Tools, under normal circumstances, cannot work until a
1348 ;;couple of packages are pre-installed by hand.  This function eliminates
1349 ;;the need to do that.  It uses FFI and libcurl to download and install
1350 ;;the lastest package index file, the EFS and xemacs-base packages.
1351
1352 ;;Obviously you can't use this if you didn't enable FFI support in your
1353 ;;SXEmacs or if you don't have libffi on your system.
1354
1355 ;;This isn't designed to replace the existing Package Tools so after
1356 ;;you have run `pui-bootstrap' once you should then use the normal PUI
1357 ;;tools, `pui-list-packages' etc."
1358 ;;  (interactive)
1359 ;;  ;; A little sanity checking never hurt anybody
1360 ;;  (when (featurep '(and efs-autoloads xemacs-base-autoloads))
1361 ;;    (error 'invalid-operation "PUI doesn't need bootstrapping"))
1362 ;;  (when (and (fboundp 'ffi-defun)
1363 ;;           (not (featurep '(and ffi ffi-curl))))
1364 ;;    (require 'ffi-curl))
1365 ;;  (unless (featurep 'ffi)
1366 ;;    (error 'unimplemented "FFI"))
1367 ;;  ;; One last check... has `package-get-remote' been set?
1368 ;;  (if (not (cdr package-get-remote))
1369 ;;      (when (y-or-n-p "You haven't set a download site, do you need help ")
1370 ;;      (declare-fboundp (Info-goto-node "(sxemacs)Bootstrapping PUI")))
1371 ;;    ;; We should be good to go
1372 ;;    (let* ((site (car package-get-remote))
1373 ;;         (dir (cadr package-get-remote))
1374 ;;         (scheme (third package-get-remote))
1375 ;;         (url (concat scheme "://" site "/" dir "/"))
1376 ;;         (dldir (temp-directory))
1377 ;;         (index (expand-file-name package-get-base-filename
1378 ;;                                  package-get-package-index-file-location))
1379 ;;         xemacs-base-pkg
1380 ;;         efs-pkg
1381 ;;                                      ;status)
1382 ;;         )
1383 ;;      ;; Grab the index
1384 ;;      (message "Retrieving index, please be patient")
1385 ;;      (declare-fboundp (curl:download (concat url package-get-base-filename) index))
1386 ;;      (message "Retrieving index, done!")
1387 ;;      ;; Update the db
1388 ;;      (set-buffer (find-file-noselect index))
1389 ;;      (package-get-update-base-from-buffer)
1390 ;;      (kill-buffer (current-buffer))
1391 ;;      ;; Get xemacs-base, EFS
1392 ;;      (setq xemacs-base-pkg (package-get-info 'xemacs-base 'filename))
1393 ;;      (setq efs-pkg (package-get-info 'efs 'filename))
1394 ;;      (message "Retrieving %s, please be patient" xemacs-base-pkg)
1395 ;;      (declare-fboundp (curl:download (concat url xemacs-base-pkg)
1396 ;;                                    (expand-file-name xemacs-base-pkg dldir)))
1397 ;;      (message "Retrieving %s, please be patient" efs-pkg)
1398 ;;      (declare-fboundp (curl:download (concat url efs-pkg)
1399 ;;                                    (expand-file-name efs-pkg dldir)))
1400 ;;      (message "Download complete.")
1401 ;;      ;; Install xemacs-base
1402 ;;      (if (equal (package-get-info 'xemacs-base 'md5sum)
1403 ;;               (with-temp-buffer
1404 ;;                 (insert-file-contents-literally
1405 ;;                  (expand-file-name xemacs-base-pkg dldir))
1406 ;;                 (md5 (current-buffer))))
1407 ;;        (progn
1408 ;;          (package-admin-add-binary-package
1409 ;;           (expand-file-name xemacs-base-pkg dldir)
1410 ;;           (package-admin-get-install-dir 'xemacs-base))
1411 ;;          (push (file-name-as-directory
1412 ;;                 (expand-file-name "lisp/xemacs-base"
1413 ;;                                   (package-admin-get-install-dir 'xemacs-base)))
1414 ;;                load-path)
1415 ;;          (load-file (expand-file-name "lisp/xemacs-base/_pkg.el"
1416 ;;                                       (package-admin-get-install-dir 'xemacs-base)))
1417 ;;          (load-file (expand-file-name "lisp/xemacs-base/auto-autoloads.el"
1418 ;;                                       (package-admin-get-install-dir 'xemacs-base)))
1419 ;;          (message "xemacs-base package installed"))
1420 ;;      (delete-file (expand-file-name xemacs-base-pkg dldir))
1421 ;;      (error "MD5 mismatch, %s deleted" (expand-file-name xemacs-base-pkg dldir)))
1422 ;;      ;; Install EFS
1423 ;;      (if (equal (package-get-info 'efs 'md5sum)
1424 ;;               (with-temp-buffer
1425 ;;                 (insert-file-contents-literally
1426 ;;                  (expand-file-name efs-pkg dldir))
1427 ;;                 (md5 (current-buffer))))
1428 ;;        (progn
1429 ;;          (package-admin-add-binary-package
1430 ;;           (expand-file-name efs-pkg dldir)
1431 ;;           (package-admin-get-install-dir 'efs))
1432 ;;          (push (file-name-as-directory
1433 ;;                 (expand-file-name "lisp/efs"
1434 ;;                                   (package-admin-get-install-dir 'efs)))
1435 ;;                load-path)
1436 ;;          (load-file (expand-file-name "lisp/efs/_pkg.el"
1437 ;;                                       (package-admin-get-install-dir 'efs)))
1438 ;;          (load-file (expand-file-name "lisp/efs/auto-autoloads.el"
1439 ;;                                       (package-admin-get-install-dir 'efs)))
1440 ;;          (message "efs package installed"))
1441 ;;      (delete-file (expand-file-name efs-pkg dldir))
1442 ;;      (error "MD5 mismatch, %s deleted" (expand-file-name efs-pkg dldir)))
1443 ;;      (when (y-or-n-p "Install more packages? ")
1444 ;;      (declare-fboundp (pui-list-packages))))))
1445
1446 (provide 'package-get)
1447
1448 ;; On-load forms
1449 (unless (and (featurep 'package-ui)
1450              (fboundp 'loop))
1451   (require 'package-ui)
1452   (load "cl-macs"))
1453
1454 ;;;###autoload (condition-case nil (require 'ffi-curl) (error nil))
1455
1456 ;;; package-get.el ends here