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