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