1 ;;; package-get.el --- Retrieve XEmacs package
3 ;; Copyright (C) 1998 by Pete Ware
5 ;; Author: Pete Ware <ware@cis.ohio-state.edu>
8 ;; This file is part of XEmacs.
10 ;; XEmacs is free software; you can redistribute it and/or modify it
11 ;; under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; XEmacs is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
25 ;;; Synched up with: Not in FSF
30 ;; Retrieve a package and any other required packages from an archive
33 ;; A new XEmacs lisp-only release is generated with the following steps:
34 ;; 1. The maintainer runs some yet to be written program that
35 ;; generates all the dependency information. This should
36 ;; determine all the require and provide statements and associate
37 ;; them with a package.
38 ;; 2. All the packages are then bundled into their own tar balls
39 ;; (or whatever format)
40 ;; 3. Maintainer automatically generates a new `package-get-base'
41 ;; data structure which contains information such as the
42 ;; package name, the file to be retrieved, an md5 checksum,
43 ;; etc (see `package-get-base').
44 ;; 4. The maintainer posts an announcement with the new version
45 ;; of `package-get-base'.
46 ;; 5. A user/system manager saves this posting and runs
47 ;; `package-get-update' which uses the previously saved list
48 ;; of packages, `package-get-here' that the user/site
49 ;; wants to determine what new versions to download and
52 ;; A user/site manager can generate a new `package-get-here' structure
53 ;; by using `package-get-setup' which generates a customize like
54 ;; interface to the list of packages. The buffer looks something
57 ;; gnus - a mail and news reader
60 ;; [] Required by other [packages]
66 ;; [] Required by other [packages]
68 ;; Where `[]' indicates a toggle box
70 ;; - Clicking on "Always install" puts this into
71 ;; `package-get-here' list. "Needs updating" indicates a new
72 ;; version is available. Anything already in
73 ;; `package-get-here' has this enabled.
74 ;; - "Required by other" means some other packages are going to force
75 ;; this to be installed. Clicking on [packages] gives a list
76 ;; of packages that require this.
78 ;; The `package-get-base' should be installed in a file in
79 ;; `data-directory'. The `package-get-here' should be installed in
80 ;; site-lisp. Both are then read at run time.
83 ;; - Implement `package-get-setup'
84 ;; - Actually put `package-get-base' and `package-get-here' into
85 ;; files that are read.
86 ;; - Allow users to have their own packages that they want installed
88 ;; - SOMEONE needs to write the programs that generate the
89 ;; provides/requires database and makes it into a lisp data
90 ;; structure suitable for `package-get-base'
91 ;; - Handle errors such as no package providing a required symbol.
92 ;; - Tie this into the `require' function to download packages
99 (require 'package-admin)
100 (require 'package-get-base)
102 (defvar package-get-base nil
103 "List of packages that are installed at this site.
104 For each element in the alist, car is the package name and the cdr is
105 a plist containing information about the package. Typical fields
106 kept in the plist are:
108 version - version of this package
109 provides - list of symbols provided
110 requires - list of symbols that are required.
111 These in turn are provided by other packages.
112 filename - name of the file.
113 size - size of the file (aka the bundled package)
114 md5sum - computed md5 checksum
115 description - What this package is for.
116 type - Whether this is a 'binary (default) or 'single file package
118 More fields may be added as needed. An example:
122 (version \"<version 2>\"
124 description \"what this package is about.\"
131 (version \"<version 1>\"
133 description \"what this package is about.\"
143 For version information, it is assumed things are listed in most
144 recent to least recent -- in other words, the version names don't have to
145 be lexically ordered. It is debatable if it makes sense to have more than
146 one version of a package available.")
148 (defvar package-get-dir (temp-directory)
149 "*Where to store temporary files for staging.")
151 (defvar package-get-remote
152 '(("ftp.xemacs.org" "/pub/xemacs/packages"))
153 "*List of remote sites to contact for downloading packages.
154 List format is '(site-name directory-on-site). Each site is tried in
155 order until the package is found. As a special case, `site-name' can be
156 `nil', in which case `directory-on-site' is treated as a local directory.")
158 (defvar package-get-remove-copy nil
159 "*After copying and installing a package, if this is T, then remove the
160 copy. Otherwise, keep it around.")
162 (defun package-get-interactive-package-query (get-version package-symbol)
163 "Perform interactive querying for package and optional version.
164 Query for a version if GET-VERSION is non-nil. Return package name as
165 a symbol instead of a string if PACKAGE-SYMBOL is non-nil.
166 The return value is suitable for direct passing to `interactive'."
167 (let ( (table (mapcar '(lambda (item)
168 (let ( (name (symbol-name (car item))) )
172 package package-symbol default-version version)
173 (save-window-excursion
174 (setq package (completing-read "Package: " table nil t))
175 (setq package-symbol (intern package))
178 (setq default-version
179 (package-get-info-prop
180 (package-get-info-version
181 (package-get-info-find-package package-get-base
185 (setq version (read-string "Version: " default-version))
189 (list package-symbol version)
190 (list package version))
193 (list package-symbol)
198 (defun package-get-delete-package (package &optional pkg-topdir)
199 "Delete an installation of PACKAGE below directory PKG-TOPDIR.
200 PACKAGE is a symbol, not a string.
201 This is just an interactive wrapper for `package-admin-delete-binary-package'."
202 (interactive (package-get-interactive-package-query nil t))
203 (package-admin-delete-binary-package package pkg-topdir))
206 (defun package-get-update-all ()
207 "Fetch and install the latest versions of all currently installed packages."
211 (mapcar (lambda (pkg)
212 (if (not (package-get (car pkg) nil 'never))
213 (throw 'exit nil) ;; Bail out if error detected
215 packages-package-list)))
218 (defun package-get-all (package version &optional fetched-packages)
219 "Fetch PACKAGE with VERSION and all other required packages.
220 Uses `package-get-base' to determine just what is required and what
221 package provides that functionality. If VERSION is nil, retrieves
222 latest version. Optional argument FETCHED-PACKAGES is used to keep
223 track of packages already fetched.
225 Returns nil upon error."
226 (interactive (package-get-interactive-package-query t nil))
227 (let* ((the-package (package-get-info-find-package package-get-base
229 (this-package (package-get-info-version
230 the-package version))
231 (this-requires (package-get-info-prop this-package 'requires))
234 (setq version (package-get-info-prop this-package 'version))
235 (unless (package-get-installedp package version)
236 (if (not (package-get package version))
238 (setq fetched-packages nil)
240 (setq fetched-packages
241 (append (list package)
242 (package-get-info-prop this-package 'provides)
244 ;; grab everything that this package requires plus recursively
245 ;; grab everything that the requires require. Keep track
246 ;; in `fetched-packages' the list of things provided -- this
247 ;; keeps us from going into a loop
249 (if (not (member (car this-requires) fetched-packages))
250 (let* ((reqd-package (package-get-package-provider
251 (car this-requires)))
252 (reqd-version (cadr reqd-package))
253 (reqd-name (car reqd-package)))
255 (error "Unable to find a provider for %s"
256 (car this-requires)))
257 (if (not (setq fetched-packages
258 (package-get-all reqd-name reqd-version
262 (setq this-requires (cdr this-requires)))
267 (defun package-get-load-package-file (lispdir file)
269 (setq pathname (expand-file-name file lispdir))
275 (message "Error loading package file \"%s\" %s!" pathname err)
279 (defun package-get-init-package (lispdir)
280 "Initialize the package.
281 This really assumes that the package has never been loaded. Updating
282 a newer package can cause problems, due to old, obsolete functions in
285 Return `t' upon complete success, `nil' if any errors occurred."
288 (file-accessible-directory-p lispdir))
290 ;; Add lispdir to load-path if it doesn't already exist.
291 ;; NOTE: this does not take symlinks, etc., into account.
292 (if (let ( (dirs load-path) )
295 (if (string-equal (car dirs) lispdir)
297 (setq dirs (cdr dirs))
300 (setq load-path (cons lispdir load-path)))
301 (if (not (package-get-load-package-file lispdir "auto-autoloads"))
302 (package-get-load-package-file lispdir "_pkg"))
308 (defun package-get (package &optional version conflict install-dir)
309 "Fetch PACKAGE from remote site.
310 Optional arguments VERSION indicates which version to retrieve, nil
311 means most recent version. CONFLICT indicates what happens if the
312 package is already installed. Valid values for CONFLICT are:
313 'always always retrieve the package even if it is already installed
314 'never do not retrieve the package if it is installed.
315 INSTALL-DIR, if non-nil, specifies the package directory where
316 fetched packages should be installed.
318 The value of `package-get-base' is used to determine what files should
319 be retrieved. The value of `package-get-remote' is used to determine
320 where a package should be retrieved from. The sites are tried in
321 order so one is better off listing easily reached sites first.
323 Once the package is retrieved, its md5 checksum is computed. If that
324 sum does not match that stored in `package-get-base' for this version
325 of the package, an error is signalled.
327 Returns `t' upon success, the symbol `error' if the package was
328 successfully installed but errors occurred during initialization, or
330 (interactive (package-get-interactive-package-query nil t))
332 (package-get-info-version
333 (package-get-info-find-package package-get-base
336 (search-dirs package-get-remote)
337 (base-filename (package-get-info-prop this-package 'filename))
339 filenames full-package-filename)
340 (if (null this-package)
341 (error "Couldn't find package %s with version %s"
343 (if (null base-filename)
344 (error "No filename associated with package %s, version %s"
346 (if (null install-dir)
347 (setq install-dir (package-admin-get-install-dir nil)))
349 ;; Contrive a list of possible package filenames.
350 ;; Ugly. Is there a better way to do this?
351 (setq filenames (cons base-filename nil))
352 (if (string-match "^\\(..*\\)\.tar\.gz$" base-filename)
353 (setq filenames (append filenames
354 (list (concat (match-string 1 base-filename)
357 (setq version (package-get-info-prop this-package 'version))
358 (unless (and (eq conflict 'never)
359 (package-get-installedp package version))
360 ;; Find the package from the search list in package-get-remote
361 ;; and copy it into the staging directory. Then validate
362 ;; the checksum. Finally, install the package.
364 (let (search-filenames current-dir-entry host dir current-filename
366 ;; In each search directory ...
368 (setq current-dir-entry (car search-dirs)
369 host (car current-dir-entry)
370 dir (car (cdr current-dir-entry))
371 search-filenames filenames
374 ;; Look for one of the possible package filenames ...
375 (while search-filenames
376 (setq current-filename (car search-filenames)
377 dest-filename (package-get-staging-dir current-filename))
379 ;; No host means look on the current system.
381 (setq full-package-filename
382 (substitute-in-file-name
383 (expand-file-name current-filename
384 (file-name-as-directory dir))))
387 ;; If it's already on the disk locally, and the size is
388 ;; greater than zero ...
389 ( (and (file-exists-p dest-filename)
391 ;; file-attributes could return -1 for LARGE files,
392 ;; but, hopefully, packages won't be that large.
393 (and (setq attrs (file-attributes dest-filename))
394 (> (nth 7 attrs) 0))))
395 (setq full-package-filename dest-filename)
398 ;; If the file exists on the remote system ...
399 ( (file-exists-p (package-get-remote-filename
400 current-dir-entry current-filename))
402 (setq full-package-filename dest-filename)
403 (message "Retrieving package `%s' ..."
406 (copy-file (package-get-remote-filename current-dir-entry
408 full-package-filename t)
412 ;; If we found it, we're done.
413 (if (and full-package-filename
414 (file-exists-p full-package-filename))
416 ;; Didn't find it. Try the next possible filename.
417 (setq search-filenames (cdr search-filenames))
419 ;; Try looking in the next possible directory ...
420 (setq search-dirs (cdr search-dirs))
424 (if (or (not full-package-filename)
425 (not (file-exists-p full-package-filename)))
426 (error "Unable to find file %s" base-filename))
427 ;; Validate the md5 checksum
428 ;; Doing it with XEmacs removes the need for an external md5 program
429 (message "Validating checksum for `%s'..." package) (sit-for 0)
431 ;; What ever happened to i-f-c-literally
432 (let (file-name-handler-alist)
433 (insert-file-contents-internal full-package-filename))
434 (if (not (string= (md5 (current-buffer))
435 (package-get-info-prop this-package
437 (error "Package %s does not match md5 checksum" base-filename)))
439 (package-admin-delete-binary-package package install-dir)
441 (message "Installing package `%s' ..." package) (sit-for 0)
443 (package-admin-add-binary-package full-package-filename
447 ;; clear messages so that only messages from
448 ;; package-get-init-package are seen, below.
450 (if (package-get-init-package (package-admin-get-lispdir
451 install-dir package))
453 (message "Added package `%s'" package)
457 ;; display message only if there isn't already one.
458 (if (not (current-message))
460 (message "Added package `%s' (errors occurred)"
465 (setq package-status 'errors))
468 (message "Installation of package %s failed." base-filename)
470 (switch-to-buffer package-admin-temp-buffer)
471 (setq package-status nil)
474 (if (and found package-get-remove-copy)
475 (delete-file full-package-filename))
479 (defun package-get-info-find-package (which name)
480 "Look in WHICH for the package called NAME and return all the info
481 associated with it. See `package-get-base' for info on the format
484 To access fields returned from this, use
485 `package-get-info-version' to return information about particular a
486 version. Use `package-get-info-find-prop' to find particular property
487 from a version returned by `package-get-info-version'."
488 (interactive "xPackage list: \nsPackage Name: ")
490 (if (eq (caar which) name)
493 (package-get-info-find-package (cdr which) name)))))
495 (defun package-get-info-version (package version)
496 "In PACKAGE, return the plist associated with a particular VERSION of the
497 package. PACKAGE is typically as returned by
498 `package-get-info-find-package'. If VERSION is nil, then return the
499 first (aka most recent) version. Use `package-get-info-find-prop'
500 to retrieve a particular property from the value returned by this."
501 (interactive (package-get-interactive-package-query t t))
502 (while (and version package (not (string= (plist-get (car package) 'version) version)))
503 (setq package (cdr package)))
504 (if package (car package)))
506 (defun package-get-info-prop (package-version property)
507 "In PACKAGE-VERSION, return the value associated with PROPERTY.
508 PACKAGE-VERSION is typically returned by `package-get-info-version'
509 and PROPERTY is typically (although not limited to) one of the
512 version - version of this package
513 provides - list of symbols provided
514 requires - list of symbols that are required.
515 These in turn are provided by other packages.
516 size - size of the bundled package
517 md5sum - computed md5 checksum"
518 (interactive "xPackage Version: \nSProperty")
519 (plist-get package-version property))
521 (defun package-get-info-version-prop (package-list package version property)
522 "In PACKAGE-LIST, search for PACKAGE with this VERSION and return
524 (package-get-info-prop
525 (package-get-info-version
526 (package-get-info-find-package package-list package) version) property))
528 (defun package-get-set-version-prop (package-list package version
530 "A utility to make it easier to add a VALUE for a specific PROPERTY
531 in this VERSION of a specific PACKAGE kept in the PACKAGE-LIST.
532 Returns the modified PACKAGE-LIST. Any missing fields are created."
535 (defun package-get-staging-dir (filename)
536 "Return a good place to stash FILENAME when it is retrieved.
537 Use `package-get-dir' for directory to store stuff.
538 Creates `package-get-dir' it it doesn't exist."
539 (interactive "FPackage filename: ")
540 (if (not (file-exists-p package-get-dir))
541 (make-directory package-get-dir))
543 (file-name-nondirectory (or (and (fboundp 'efs-ftp-path)
544 (nth 2 (efs-ftp-path filename)))
546 (file-name-as-directory package-get-dir)))
548 (defun package-get-remote-filename (search filename)
549 "Return FILENAME as a remote filename.
550 It first checks if FILENAME already is a remote filename. If it is
551 not, then it uses the (car search) as the remote site-name and the (cadr
552 search) as the remote-directory and concatenates filename. In other
554 site-name:remote-directory/filename
556 (if (efs-ftp-path filename)
558 (let ((dir (cadr search)))
561 (if (string-match "/$" dir)
567 (defun package-get-installedp (package version)
568 "Determine if PACKAGE with VERSION has already been installed.
569 I'm not sure if I want to do this by searching directories or checking
570 some built in variables. For now, use packages-package-list."
571 ;; Use packages-package-list which contains name and version
573 (package-get-info-find-package packages-package-list
575 (if (floatp version) version (string-to-number version))))
578 (defun package-get-package-provider (sym)
579 "Search for a package that provides SYM and return the name and
580 version. Searches in `package-get-base' for SYM. If SYM is a
581 consp, then it must match a corresponding (provide (SYM VERSION)) from
583 (interactive "SSymbol: ")
584 (let ((packages package-get-base)
587 (while (and (not done) packages)
588 (let* ((this-name (caar packages))
589 (this-package (cdr (car packages)))) ;strip off package name
590 (while (and (not done) this-package)
591 (if (or (eq this-name sym)
593 (package-get-info-prop (car this-package) 'version))
595 (member sym (package-get-info-prop (car this-package) 'provides)))
597 (setq found (list (caar packages)
598 (package-get-info-prop (car this-package) 'version))))
599 (setq this-package (cdr this-package)))))
600 (setq packages (cdr packages)))
604 ;; customize interfaces.
605 ;; The group is in this file so that custom loads includes this file.
607 (defgroup packages nil
608 "Configure XEmacs packages."
612 (defun package-get-custom ()
613 "Fetch and install the latest versions of all customized packages."
616 (load "package-get-custom.el")
617 (mapcar (lambda (pkg)
618 (if (eval (intern (concat (symbol-name (car pkg)) "-package")))
619 (package-get-all (car pkg) nil))
623 (defun package-get-ever-installed-p (pkg &optional notused)
624 (string-match "-package$" (symbol-name pkg))
625 (custom-initialize-set
627 (if (package-get-info-find-package
628 packages-package-list
629 (intern (substring (symbol-name pkg) 0 (match-beginning 0))))
632 (defun package-get-file-installed-p (file &optional paths)
633 "Return absolute-path of FILE if FILE exists in PATHS.
634 If PATHS is omitted, `load-path' is used."
636 (setq paths load-path)
641 (setq path (expand-file-name file (car paths)))
642 (if (file-exists-p path)
645 (setq paths (cdr paths))
648 (defun package-get-create-custom ()
649 "Creates a package customization file package-get-custom.el.
650 Entries in the customization file are retrieved from package-get-base.el."
653 (let ((custom-buffer (find-file-noselect
654 (or (package-get-file-installed-p
655 "package-get-custom.el")
657 "package-get-custom.el"
659 (package-get-file-installed-p
660 "package-get-base.el"))
664 ;; clear existing stuff
665 (delete-region (point-min custom-buffer)
666 (point-max custom-buffer) custom-buffer)
667 (insert-string "(require 'package-get)\n" custom-buffer)
669 (mapcar (lambda (pkg)
670 (let ((category (plist-get (car (cdr pkg)) 'category)))
671 (or (memq (intern category) pkg-groups)
673 (setq pkg-groups (cons (intern category) pkg-groups))
675 (concat "(defgroup " category "-packages nil\n"
676 " \"" category " package group\"\n"
677 " :group 'packages)\n\n") custom-buffer)))
680 (concat "(defcustom " (symbol-name (car pkg))
682 " \"" (plist-get (car (cdr pkg)) 'description) "\"\n"
683 " :group '" category "-packages\n"
684 " :initialize 'package-get-ever-installed-p\n"
685 " :type 'boolean)\n\n") custom-buffer)))
686 package-get-base) custom-buffer)
689 ;; need this first to avoid infinite dependency loops
690 (provide 'package-get)
692 ;; potentially update the custom dependencies every time we load this
693 (let ((custom-file (package-get-file-installed-p "package-get-custom.el"))
694 (package-file (package-get-file-installed-p "package-get-base.el")))
695 ;; update custom file if it doesn't exist
696 (if (or (not custom-file)
697 (and (< (car (nth 5 (file-attributes custom-file)))
698 (car (nth 5 (file-attributes package-file))))
699 (< (car (nth 5 (file-attributes custom-file)))
700 (car (nth 5 (file-attributes package-file))))))
702 (message "generating package customizations...")
703 (set-buffer (package-get-create-custom))
705 (message "generating package customizations...done")))
706 (load "package-get-custom.el"))
708 ;;; package-get.el ends here