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