git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/package-get.el

   1 ;;; package-get.el --- Retrieve XEmacs package
   2
   3 ;; Copyright (C) 1998 by Pete Ware
   4
   5 ;; Author: Pete Ware <ware@cis.ohio-state.edu>
   6 ;; Keywords: internal
   7
   8 ;; This file is part of XEmacs.
   9
  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)
  13 ;; any later version.
  14
  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.
  19
  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
  23 ;; 02111-1307, USA.
  24
  25 ;;; Synched up with: Not in FSF
  26
  27 ;;; Commentary:
  28
  29 ;; package-get -
  30 ;;      Retrieve a package and any other required packages from an archive
  31 ;;
  32 ;; The idea:
  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
  50 ;;         install.
  51 ;;
  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
  55 ;;      like:
  56 ;;
  57 ;;      gnus    - a mail and news reader
  58 ;;      []      Always install
  59 ;;      []      Needs updating
  60 ;;      []      Required by other [packages]
  61 ;;      version: 2.0
  62 ;;
  63 ;;      vm      - a mail reader
  64 ;;      []      Always install
  65 ;;      []      Needs updating
  66 ;;      []      Required by other [packages]
  67 ;;
  68 ;;      Where `[]' indicates a toggle box
  69 ;;
  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.
  77 ;;
  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.
  81 ;;
  82 ;; TODO:
  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
  87 ;;        in ~/.xemacs/.
  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
  93 ;;        transparently.
  94
  95 ;;; Change Log
  96
  97 ;;; Code:
  98
  99 (require 'package-admin)
 100 (require 'package-get-base)
 101
 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:
 107
 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
 117
 118 More fields may be added as needed.  An example:
 119
 120 '(
 121  (name
 122   (version \"<version 2>\"
 123    file \"filename\"
 124    description \"what this package is about.\"
 125    provides (<list>)
 126    requires (<list>)
 127    size <integer-bytes>
 128    md5sum \"<checksum\"
 129    type single
 130    )
 131   (version \"<version 1>\"
 132    file \"filename\"
 133    description \"what this package is about.\"
 134    provides (<list>)
 135    requires (<list>)
 136    size <integer-bytes>
 137    md5sum \"<checksum\"
 138    type single
 139    )
 140    ...
 141    ))
 142
 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.")
 147
 148 (defvar package-get-dir (temp-directory)
 149   "*Where to store temporary files for staging.")
 150
 151 (defvar package-get-remote
 152   '(
 153     ("ftp.xemacs.org" "/pub/xemacs/beta/xemacs-21.0/packages/binary-packages")
 154     ("ftp.xemacs.org" "/pub/xemacs/beta/xemacs-21.0/packages/single-file-packages")
 155     ("ftp.xemacs.org" "/pub/xemacs/package"))
 156   "*List of remote sites to contact for downloading packages.
 157 List format is '(site-name directory-on-site).  Each site is tried in
 158 order until the package is found.")
 159
 160 (defvar package-get-remove-copy nil
 161   "*After copying and installing a package, if this is T, then remove the
 162 copy.  Otherwise, keep it around.")
 163
 164 ;;;###autoload
 165 (defun package-get-update-all ()
 166   "Fetch and install the latest versions of all currently installed packages."
 167   (interactive)
 168   ;; Load a fresh copy
 169   (mapcar (lambda (pkg)
 170             (package-get-all
 171              (car pkg) nil))
 172           packages-package-list))
 173
 174 ;;;###autoload
 175 (defun package-get-all (package version &optional fetched-packages)
 176   "Fetch PACKAGE with VERSION and all other required packages.
 177 Uses `package-get-base' to determine just what is required and what
 178 package provides that functionality.  If VERSION is nil, retrieves
 179 latest version.  Optional argument FETCHED-PACKAGES is used to keep
 180 track of packages already fetched."
 181   (interactive "sPackage: \nsVersion: ")
 182   (let* ((the-package (package-get-info-find-package package-get-base
 183                                                      package))
 184          (this-package (package-get-info-version
 185                         the-package version))
 186          (this-requires (package-get-info-prop this-package 'requires))
 187          )
 188     (setq version (package-get-info-prop this-package 'version))
 189     (unless (package-get-installedp package version)
 190       (package-get package version))
 191     (setq fetched-packages
 192           (append (list package)
 193                   (package-get-info-prop this-package 'provides)
 194                   fetched-packages))
 195     ;; grab everything that this package requires plus recursively
 196     ;; grab everything that the requires require.  Keep track
 197     ;; in `fetched-packages' the list of things provided -- this
 198     ;; keeps us from going into a loop
 199     (while this-requires
 200       (if (not (member (car this-requires) fetched-packages))
 201           (let* ((reqd-package (package-get-package-provider
 202                                 (car this-requires)))
 203                  (reqd-version (cadr reqd-package))
 204                  (reqd-name (car reqd-package)))
 205             (if (null reqd-name)
 206                 (error "Unable to find a provider for %s" (car this-requires)))
 207             (setq fetched-packages
 208                   (package-get-all reqd-name reqd-version fetched-packages)))
 209         )
 210       (setq this-requires (cdr this-requires)))
 211     fetched-packages
 212     ))
 213
 214 ;;;###autoload
 215 (defun package-get (package &optional version conflict)
 216   "Fetch PACKAGE from remote site.
 217 Optional arguments VERSION indicates which version to retrieve, nil
 218 means most recent version.  CONFLICT indicates what happens if the
 219 package is already installed.  Valid values for CONFLICT are:
 220 'always always retrieve the package even if it is already installed
 221 'never  do not retrieve the package if it is installed.
 222
 223 The value of `package-get-base' is used to determine what files should
 224 be retrieved.  The value of `package-get-remote' is used to determine
 225 where a package should be retrieved from.  The sites are tried in
 226 order so one is better off listing easily reached sites first.
 227
 228 Once the package is retrieved, its md5 checksum is computed.  If that
 229 sum does not match that stored in `package-get-base' for this version
 230 of the package, an error is signalled."
 231   (interactive "xPackage List: ")
 232   (let* ((this-package
 233           (package-get-info-version
 234            (package-get-info-find-package package-get-base
 235                                           package) version))
 236          (found nil)
 237          (search-dirs package-get-remote)
 238          (filename (package-get-info-prop this-package 'filename)))
 239     (if (null this-package)
 240         (error "Couldn't find package %s with version %s"
 241                package version))
 242     (if (null filename)
 243         (error "No filename associated with package %s, version %s"
 244                package version))
 245     (setq version (package-get-info-prop this-package 'version))
 246     (unless (and (eq conflict 'never)
 247                  (package-get-installedp package version))
 248       ;; Find the package from search list in package-get-remote
 249       ;; and copy it into the staging directory.  Then validate
 250       ;; the checksum.  Finally, install the package.
 251       (while (and search-dirs
 252                   (not (file-exists-p (package-get-staging-dir filename))))
 253         (if (file-exists-p (package-get-remote-filename
 254                             (car search-dirs) filename))
 255             (copy-file (package-get-remote-filename (car search-dirs) filename)
 256                        (package-get-staging-dir filename))
 257           (setq search-dirs (cdr search-dirs))
 258           ))
 259       (if (not (file-exists-p (package-get-staging-dir filename)))
 260           (error "Unable to find file %s" filename))
 261       ;; Validate the md5 checksum
 262       ;; Doing it with XEmacs removes the need for an external md5 program
 263       (with-temp-buffer
 264         ;; What ever happened to i-f-c-literally
 265         (let (file-name-handler-alist)
 266           (insert-file-contents-internal (package-get-staging-dir filename)))
 267         (if (not (string= (md5 (current-buffer))
 268                           (package-get-info-prop this-package
 269                                                  'md5sum)))
 270             (error "Package %s does not match md5 checksum" filename)))
 271       (message "Retrieved package %s" filename) (sit-for 0)
 272       (let ((status
 273              (package-admin-add-binary-package
 274               (package-get-staging-dir filename))))
 275         (when (not (= status 0))
 276           (message "Package failed.")
 277           (switch-to-buffer package-admin-temp-buffer)))
 278       (sit-for 0)
 279       (message "Added package") (sit-for 0)
 280       (setq found t))
 281     (if (and found package-get-remove-copy)
 282         (delete-file (package-get-staging-dir filename)))
 283     ))
 284
 285 (defun package-get-info-find-package (which name)
 286   "Look in WHICH for the package called NAME and return all the info
 287 associated with it.  See `package-get-base' for info on the format
 288 returned.
 289
 290  To access fields returned from this, use
 291 `package-get-info-version' to return information about particular a
 292 version.  Use `package-get-info-find-prop' to find particular property
 293 from a version returned by `package-get-info-version'."
 294   (interactive "xPackage list: \nsPackage Name: ")
 295   (if which
 296       (if (eq (caar which) name)
 297           (cdar which)
 298         (if (cdr which)
 299             (package-get-info-find-package (cdr which) name)))))
 300
 301 (defun package-get-info-version (package version)
 302   "In PACKAGE, return the plist associated with a particular VERSION of the
 303   package.  PACKAGE is typically as returned by
 304   `package-get-info-find-package'.  If VERSION is nil, then return the
 305   first (aka most recent) version.  Use `package-get-info-find-prop'
 306   to retrieve a particular property from the value returned by this."
 307   (interactive "xPackage Info: \nsVersion: ")
 308   (while (and version package (not (string= (plist-get (car package) 'version) version)))
 309     (setq package (cdr package)))
 310   (if package (car package)))
 311
 312 (defun package-get-info-prop (package-version property)
 313   "In PACKAGE-VERSION, return the value associated with PROPERTY.
 314 PACKAGE-VERSION is typically returned by `package-get-info-version'
 315 and PROPERTY is typically (although not limited to) one of the
 316 following:
 317
 318 version         - version of this package
 319 provides                - list of symbols provided
 320 requires                - list of symbols that are required.
 321                   These in turn are provided by other packages.
 322 size            - size of the bundled package
 323 md5sum          - computed md5 checksum"
 324   (interactive "xPackage Version: \nSProperty")
 325   (plist-get package-version property))
 326
 327 (defun package-get-info-version-prop (package-list package version property)
 328   "In PACKAGE-LIST, search for PACKAGE with this VERSION and return
 329   PROPERTY value."
 330   (package-get-info-prop
 331    (package-get-info-version
 332     (package-get-info-find-package package-list package) version) property))
 333
 334 (defun package-get-set-version-prop (package-list package version
 335                                                   property value)
 336   "A utility to make it easier to add a VALUE for a specific PROPERTY
 337   in this VERSION of a specific PACKAGE kept in the PACKAGE-LIST.
 338 Returns the modified PACKAGE-LIST.  Any missing fields are created."
 339   )
 340
 341 (defun package-get-staging-dir (filename)
 342   "Return a good place to stash FILENAME when it is retrieved.
 343 Use `package-get-dir' for directory to store stuff.
 344 Creates `package-get-dir'  it it doesn't exist."
 345   (interactive "FPackage filename: ")
 346   (if (not (file-exists-p package-get-dir))
 347       (make-directory package-get-dir))
 348   (concat
 349    (file-name-as-directory package-get-dir)
 350    (file-name-nondirectory (or (nth 2 (efs-ftp-path filename)) filename))))
 351
 352
 353 (defun package-get-remote-filename (search filename)
 354   "Return FILENAME as a remote filename.
 355 It first checks if FILENAME already is a remote filename.  If it is
 356 not, then it uses the (car search) as the remote site-name and the (cadr
 357 search) as the remote-directory and concatenates filename.  In other
 358 words
 359         site-name:remote-directory/filename
 360 "
 361   (if (efs-ftp-path filename)
 362       filename
 363     (let ((dir (cadr search)))
 364       (concat "/"
 365               (car search) ":"
 366               (if (string-match "/$" dir)
 367                   dir
 368                 (concat dir "/"))
 369               filename))))
 370
 371
 372 (defun package-get-installedp (package version)
 373   "Determine if PACKAGE with VERSION has already been installed.
 374 I'm not sure if I want to do this by searching directories or checking
 375 some built in variables.  For now, use packages-package-list."
 376   ;; Use packages-package-list which contains name and version
 377   (equal (plist-get
 378           (package-get-info-find-package packages-package-list
 379                                          package) ':version)
 380          (if (floatp version) version (string-to-number version))))
 381
 382 ;;;###autoload
 383 (defun package-get-package-provider (sym)
 384   "Search for a package that provides SYM and return the name and
 385   version.  Searches in `package-get-base' for SYM.   If SYM is a
 386   consp, then it must match a corresponding (provide (SYM VERSION)) from
 387   the package."
 388   (interactive "SSymbol: ")
 389   (let ((packages package-get-base)
 390         (done nil)
 391         (found nil))
 392     (while (and (not done) packages)
 393       (let* ((this-name (caar packages))
 394              (this-package (cdr (car packages)))) ;strip off package name
 395         (while (and (not done) this-package)
 396           (if (or (eq this-name sym)
 397                   (eq (cons this-name
 398                             (package-get-info-prop (car this-package) 'version))
 399                       sym)
 400                   (member sym (package-get-info-prop (car this-package) 'provides)))
 401               (progn (setq done t)
 402                      (setq found (list (caar packages)
 403                                        (package-get-info-prop (car this-package) 'version))))
 404             (setq this-package (cdr this-package)))))
 405       (setq packages (cdr packages)))
 406     found))
 407
 408 ;;
 409 ;; customize interfaces.
 410 ;; The group is in this file so that custom loads includes this file.
 411 ;;
 412 (defgroup packages nil
 413   "Configure XEmacs packages."
 414   :group 'emacs)
 415
 416 ;;;###autoload
 417 (defun package-get-custom ()
 418   "Fetch and install the latest versions of all customized packages."
 419   (interactive)
 420   ;; Load a fresh copy
 421   (load "package-get-custom.el")
 422   (mapcar (lambda (pkg)
 423             (if (eval (intern (concat (symbol-name (car pkg)) "-package")))
 424                 (package-get-all (car pkg) nil))
 425             t)
 426           package-get-base))
 427
 428 (defun package-get-ever-installed-p (pkg &optional notused)
 429   (string-match "-package$" (symbol-name pkg))
 430   (custom-initialize-set
 431    pkg
 432    (if (package-get-info-find-package
 433         packages-package-list
 434         (intern (substring (symbol-name pkg) 0 (match-beginning 0))))
 435        t)))
 436
 437 (defun package-get-file-installed-p (file &optional paths)
 438   "Return absolute-path of FILE if FILE exists in PATHS.
 439 If PATHS is omitted, `load-path' is used."
 440   (if (null paths)
 441       (setq paths load-path)
 442     )
 443   (catch 'tag
 444     (let (path)
 445       (while paths
 446         (setq path (expand-file-name file (car paths)))
 447         (if (file-exists-p path)
 448             (throw 'tag path)
 449           )
 450         (setq paths (cdr paths))
 451         ))))
 452
 453 (defun package-get-create-custom ()
 454   "Creates a package customization file package-get-custom.el.
 455 Entries in the customization file are retrieved from package-get-base.el."
 456   (interactive)
 457   ;; Load a fresh copy
 458   (let ((custom-buffer (find-file-noselect
 459                         (or (package-get-file-installed-p
 460                              "package-get-custom.el")
 461                             (concat (file-name-directory
 462                                      (package-get-file-installed-p
 463                                       "package-get-base.el"))
 464                                     "package-get-custom.el"))))
 465         (pkg-groups nil))
 466
 467     ;; clear existing stuff
 468     (delete-region (point-min custom-buffer)
 469                    (point-max custom-buffer) custom-buffer)
 470     (insert-string "(require 'package-get)\n" custom-buffer)
 471
 472     (mapcar (lambda (pkg)
 473               (let ((category (plist-get (car (cdr pkg)) 'category)))
 474                 (or (memq (intern category) pkg-groups)
 475                     (progn
 476                       (setq pkg-groups (cons (intern category) pkg-groups))
 477                       (insert-string
 478                        (concat "(defgroup " category "-packages nil\n"
 479                                "  \"" category " package group\"\n"
 480                                "  :group 'packages)\n\n") custom-buffer)))
 481
 482                 (insert-string
 483                  (concat "(defcustom " (symbol-name (car pkg))
 484                          "-package nil \n"
 485                          "  \"" (plist-get (car (cdr pkg)) 'description) "\"\n"
 486                          "  :group '" category "-packages\n"
 487                          "  :initialize 'package-get-ever-installed-p\n"
 488                          "  :type 'boolean)\n\n") custom-buffer)))
 489             package-get-base) custom-buffer)
 490   )
 491
 492 ;; need this first to avoid infinite dependency loops
 493 (provide 'package-get)
 494
 495 ;; potentially update the custom dependencies every time we load this
 496 (let ((custom-file (package-get-file-installed-p "package-get-custom.el"))
 497       (package-file (package-get-file-installed-p "package-get-base.el")))
 498   ;; update custom file if it doesn't exist
 499   (if (or (not custom-file)
 500           (and (< (car (nth 5 (file-attributes custom-file)))
 501                   (car (nth 5 (file-attributes package-file))))
 502                (< (car (nth 5 (file-attributes custom-file)))
 503                   (car (nth 5 (file-attributes package-file))))))
 504       (save-excursion
 505         (message "generating package customizations...")
 506         (set-buffer (package-get-create-custom))
 507         (save-buffer)
 508         (message "generating package customizations...done")))
 509   (load "package-get-custom.el"))
 510
 511 ;;; package-get.el ends here