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

   1 ;;; package-admin.el --- Installation and Maintenance of XEmacs packages
   2
   3 ;; Copyright (C) 1997 by Free Software Foundation, Inc.
   4
   5 ;; Author: SL Baur <steve@xemacs.org>
   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 ;; First pass at lisp front end to package maintenance.
  30
  31 ;;; Code:
  32
  33 (require 'config)
  34
  35 (defvar package-admin-xemacs (concat invocation-directory invocation-name)
  36   "Location of XEmacs binary to use.")
  37
  38 (defvar package-admin-temp-buffer "*Package Output*"
  39   "Temporary buffer where output of backend commands is saved.")
  40
  41 (defvar package-admin-install-function (if (eq system-type 'windows-nt)
  42                                            'package-admin-install-function-mswindows
  43                                          'package-admin-default-install-function)
  44   "The function to call to install a package.
  45 Three args are passed: FILENAME PKG-DIR BUFFER
  46 Install package FILENAME into directory PKG-DIR, with any messages output
  47 to buffer BUFFER.")
  48
  49 (defvar package-admin-error-messages '(
  50                                        "No space left on device"
  51                                        "No such file or directory"
  52                                        "Filename too long"
  53                                        "Read-only file system"
  54                                        "File too large"
  55                                        "Too many open files"
  56                                        "Not enough space"
  57                                        "Permission denied"
  58                                        "Input/output error"
  59                                        "Out of memory"
  60                                        "Unable to create directory"
  61                                        "Directory checksum error"
  62                                        "Cannot exclusively open file"
  63                                        "corrupted file"
  64                                        "incomplete .* tree"
  65                                        "Bad table"
  66                                        "corrupt input"
  67                                        "invalid compressed data"
  68                                        "too many leaves in Huffman tree"
  69                                        "not a valid zip file"
  70                                        "first entry not deflated or stored"
  71                                        "encrypted file --"
  72                                        "unexpected end of file"
  73                                        )
  74   "Regular expressions of possible error messages.
  75 After each package extraction, the `package-admin-temp-buffer' buffer is
  76 scanned for these messages.  An error code is returned if one of these are
  77 found.
  78
  79 This is awful, but it exists because error return codes aren't reliable
  80 under MS Windows.")
  81
  82 (defvar package-admin-tar-filename-regexps
  83   '(
  84     ;; GNU tar:
  85     ;; drwxrwxr-x john/doe 123 1997-02-18 15:48 pathname
  86     "\\S-+\\s-+[-a-z0-9_/]+\\s-+[0-9]+\\s-+[-0-9]+\\s-+[0-9:]+\\s-+\\(\\S-.*\\)"
  87     ;; HP-UX & SunOS tar:
  88     ;; rwxrwxr-x 501/501    123 Feb 18 15:46 1997 pathname
  89     ;; Solaris tar (phooey!):
  90     ;; rwxrwxr-x501/501    123 Feb 18 15:46 1997 pathname
  91     ;; AIX tar:
  92     ;; -rw-r--r-- 147 1019   32919 Mar 26 12:00:09 1992 pathname
  93     "\\S-+\\s-*[-a-z0-9_]+[/ ][-a-z0-9_]+\\s-+[0-9]+\\s-+[a-z][a-z][a-z]\\s-+[0-9]+\\s-+[0-9:]+\\s-+[0-9]+\\s-+\\(\\S-.*\\)"
  94
  95     ;; djtar:
  96     ;; drwx Aug 31 02:01:41 1998       123 pathname
  97     "\\S-+\\s-+[a-z][a-z][a-z]\\s-+[0-9]+\\s-+[0-9:]+\\s-+[0-9]+\\s-+[0-9]+\\s-+\\(\\S-.*\\)"
  98
  99     )
 100   "List of regexps to use to search for tar filenames.
 101 Note that \"\\(\" and \"\\)\" must be used to delimit the pathname (as
 102 match #1).  Don't put \"^\" to match the beginning of the line; this
 103 is already implicit, as `looking-at' is used.  Filenames can,
 104 unfortunately, contain spaces, so be careful in constructing any
 105 regexps.")
 106
 107 (defvar package-install-hook nil
 108   "*List of hook functions to be called when a new package is successfully
 109 installed. The hook function is passed two arguments: the package name, and
 110 the install directory.")
 111
 112 (defvar package-delete-hook nil
 113   "*List of hook functions to be called when a package is deleted. The
 114 hook is called *before* the package is deleted. The hook function is passed
 115 two arguments: the package name, and the install directory.")
 116
 117 ;;;###autoload
 118 (defun package-admin-add-single-file-package (file destdir &optional pkg-dir)
 119   "Install a single file Lisp package into XEmacs package hierarchy.
 120 `file' should be the full path to the lisp file to install.
 121 `destdir' should be a simple directory name.
 122 The optional `pkg-dir' can be used to override the default package hierarchy
 123 \(car \(last late-packages))."
 124   (interactive "fLisp File: \nsDestination: ")
 125   (when (null pkg-dir)
 126     (setq pkg-dir (car (last late-packages))))
 127   (let ((destination (concat pkg-dir "/lisp/" destdir))
 128         (buf (get-buffer-create package-admin-temp-buffer)))
 129     (call-process "add-little-package.sh"
 130                   nil
 131                   buf
 132                   t
 133                   ;; rest of command line follows
 134                   package-admin-xemacs file destination)))
 135
 136 (defun package-admin-install-function-mswindows (file pkg-dir buffer)
 137   "Install function for mswindows."
 138   (let ((default-directory (file-name-as-directory pkg-dir)))
 139     (unless (file-directory-p default-directory)
 140       (make-directory default-directory t))
 141     (call-process "minitar" nil buffer t file)))
 142
 143 (defun package-admin-default-install-function (filename pkg-dir buffer)
 144   "Default function to install a package.
 145 Install package FILENAME into directory PKG-DIR, with any messages output
 146 to BUFFER."
 147   (let* ((pkg-dir (file-name-as-directory pkg-dir))
 148          (default-directory pkg-dir)
 149          (filename (expand-file-name filename)))
 150     (unless (file-directory-p pkg-dir)
 151       (make-directory pkg-dir t))
 152     ;; Don't assume GNU tar.
 153     (if (shell-command (concat "gunzip -c " filename " | tar xvf -") buffer)
 154         0
 155       1)
 156     ))
 157
 158 ;  (call-process "add-big-package.sh"
 159 ;               nil
 160 ;               buffer
 161 ;               t
 162 ;               ;; rest of command line follows
 163 ;               package-admin-xemacs file pkg-dir))
 164
 165 (defun package-admin-get-install-dir (package pkg-dir &optional mule-related)
 166   "If PKG-DIR is non-nil return that,
 167 else return the current location of the package if it is already installed
 168 or return a location appropriate for the package otherwise."
 169   (if pkg-dir
 170       pkg-dir
 171     (let ((package-feature (intern-soft (concat
 172                                          (symbol-name package) "-autoloads")))
 173           autoload-dir)
 174       (when (and (not (eq package 'unknown))
 175                  (featurep package-feature)
 176                  (setq autoload-dir (feature-file package-feature))
 177                  (setq autoload-dir (file-name-directory autoload-dir))
 178                  (member autoload-dir (append early-package-load-path late-package-load-path)))
 179         ;; Find the corresponding entry in late-package
 180         (setq pkg-dir
 181               (car-safe (member-if (lambda (h)
 182                            (string-match (concat "^" (regexp-quote h))
 183                                          autoload-dir))
 184                          (append (cdr early-packages) late-packages)))))
 185       (if pkg-dir
 186           pkg-dir
 187         ;; Ok we need to guess
 188         (if mule-related
 189             (package-admin-get-install-dir 'mule-base nil nil)
 190           (if (eq package 'xemacs-base)
 191               (car (last late-packages))
 192             (package-admin-get-install-dir 'xemacs-base nil nil)))))))
 193
 194
 195
 196 (defun package-admin-get-manifest-file (pkg-topdir package)
 197   "Return the name of the MANIFEST file for package PACKAGE.
 198 Note that PACKAGE is a symbol, and not a string."
 199   (let (dir)
 200     (setq dir (expand-file-name "pkginfo" pkg-topdir))
 201     (expand-file-name (concat "MANIFEST." (symbol-name package)) dir)
 202     ))
 203
 204 (defun package-admin-check-manifest (pkg-outbuf pkg-topdir)
 205   "Check for a MANIFEST.<package> file in the package distribution.
 206 If it doesn't exist, create and write one.
 207 PKG-OUTBUF is the buffer that holds the output from `tar', and PKG-TOPDIR
 208 is the top-level directory under which the package was installed."
 209   (let ( (manifest-buf " *pkg-manifest*")
 210          old-case-fold-search regexp package-name pathname regexps)
 211     ;; Save and restore the case-fold-search status.
 212     ;; We do this in case we have to screw with it (as it the case of
 213     ;; case-insensitive filesystems such as MS Windows).
 214     (setq old-case-fold-search case-fold-search)
 215     (unwind-protect
 216         (save-excursion                         ;; Probably redundant.
 217           (set-buffer (get-buffer pkg-outbuf))  ;; Probably already the
 218                                                 ;; current buffer.
 219           (goto-char (point-min))
 220
 221           ;; Make filenames case-insensitive, if necessary
 222           (if (eq system-type 'windows-nt)
 223               (setq case-fold-search t))
 224
 225           ;; We really should compute the regexp.
 226           ;; However, directory-sep-char is currently broken, but we need
 227           ;; functional code *NOW*.
 228           (setq regexp "\\bpkginfo[\\/]MANIFEST\\...*")
 229
 230           ;; Look for the manifest.
 231           (if (not (re-search-forward regexp nil t))
 232               (progn
 233                 ;; We didn't find a manifest.  Make one.
 234
 235                 ;; Yuk.  We weren't passed the package name, and so we have
 236                 ;; to dig for it.  Look for it as the subdirectory name below
 237                 ;; "lisp", "man", "info", or "etc".
 238                 ;; Here, we don't use a single regexp because we want to search
 239                 ;; the directories for a package name in a particular order.
 240                 ;; The problem is that packages could have directories like
 241                 ;; "etc/sounds/" or "etc/photos/" and we don't want to get
 242                 ;; these confused with the actual package name (although, in
 243                 ;; the case of "etc/sounds/", it's probably correct).
 244                 (if (catch 'done
 245                       (let ( (dirs '("lisp" "info" "man" "etc")) rexp)
 246                         (while dirs
 247                           (setq rexp (concat "\\b" (car dirs)
 248                                              "[\\/]\\([^\\/]+\\)[\//]"))
 249                           (if (re-search-forward rexp nil t)
 250                               (throw 'done t))
 251                           (setq dirs (cdr dirs))
 252                           )))
 253                     (progn
 254                       (setq package-name (buffer-substring (match-beginning 1)
 255                                                            (match-end 1)))
 256
 257                       ;; Get and erase the manifest buffer
 258                       (setq manifest-buf (get-buffer-create manifest-buf))
 259                       (buffer-disable-undo manifest-buf)
 260                       (erase-buffer manifest-buf)
 261
 262                       ;; Now, scan through the output buffer, looking for
 263                       ;; file and directory names.
 264                       (goto-char (point-min))
 265                       ;; for each line ...
 266                       (while (< (point) (point-max))
 267                         (beginning-of-line)
 268                         (setq pathname nil)
 269
 270                         ;; scan through the regexps, looking for a pathname
 271                         (if (catch 'found-path
 272                               (setq regexps package-admin-tar-filename-regexps)
 273                               (while regexps
 274                                 (if (looking-at (car regexps))
 275                                     (progn
 276                                       (setq pathname
 277                                             (buffer-substring
 278                                              (match-beginning 1)
 279                                              (match-end 1)))
 280                                       (throw 'found-path t)
 281                                       ))
 282                                 (setq regexps (cdr regexps))
 283                                 )
 284                               )
 285                             (progn
 286                               ;; found a pathname -- add it to the manifest
 287                               ;; buffer
 288                               (save-excursion
 289                                 (set-buffer manifest-buf)
 290                                 (goto-char (point-max))
 291                                 (insert pathname "\n")
 292                                 )
 293                               ))
 294                         (forward-line 1)
 295                         )
 296
 297                       ;; Processed all lines.
 298                       ;; Now, create the file, pkginfo/MANIFEST.<pkgname>
 299
 300                       ;; We use `expand-file-name' instead of `concat',
 301                       ;; for portability.
 302                       (setq pathname (expand-file-name "pkginfo"
 303                                                        pkg-topdir))
 304                       ;; Create pkginfo, if necessary
 305                       (if (not (file-directory-p pathname))
 306                           (make-directory pathname))
 307                       (setq pathname (expand-file-name
 308                                       (concat "MANIFEST." package-name)
 309                                       pathname))
 310                       (save-excursion
 311                         (set-buffer manifest-buf)
 312                         ;; Put the files in sorted order
 313                         (sort-lines nil (point-min) (point-max))
 314                         ;; Write the file.
 315                         ;; Note that using `write-region' *BYPASSES* any check
 316                         ;; to see if XEmacs is currently editing/visiting the
 317                         ;; file.
 318                         (write-region (point-min) (point-max) pathname)
 319                         )
 320                       (kill-buffer manifest-buf)
 321                       )
 322                   (progn
 323                     ;; We can't determine the package name from an extracted
 324                     ;; file in the tar output buffer.
 325                     ))
 326                 ))
 327           )
 328       ;; Restore old case-fold-search status
 329       (setq case-fold-search old-case-fold-search))
 330     ))
 331
 332 ;;;###autoload
 333 (defun package-admin-add-binary-package (file &optional pkg-dir)
 334   "Install a pre-bytecompiled XEmacs package into package hierarchy."
 335   (interactive "fPackage tarball: ")
 336   (let ((buf (get-buffer-create package-admin-temp-buffer))
 337         (status 1)
 338         start err-list
 339         )
 340     (setq pkg-dir (package-admin-get-install-dir 'unknown pkg-dir))
 341     ;; Ensure that the current directory doesn't change
 342     (save-excursion
 343       (set-buffer buf)
 344       ;; This is not really needed
 345       (setq default-directory (file-name-as-directory pkg-dir))
 346       (setq case-fold-search t)
 347       (buffer-disable-undo)
 348       (goto-char (setq start (point-max)))
 349       (if (= 0 (setq status (funcall package-admin-install-function
 350                                      file pkg-dir buf)))
 351           (progn
 352             ;; First, check for errors.
 353             ;; We can't necessarily rely upon process error codes.
 354             (catch 'done
 355               (goto-char start)
 356               (setq err-list package-admin-error-messages)
 357               (while err-list
 358                 (if (re-search-forward (car err-list) nil t)
 359                     (progn
 360                       (setq status 1)
 361                       (throw 'done nil)
 362                       ))
 363                 (setq err-list (cdr err-list))
 364                 )
 365               )
 366             ;; Make sure that the MANIFEST file exists
 367             (package-admin-check-manifest buf pkg-dir)
 368             ))
 369       )
 370     status
 371     ))
 372
 373 (defun package-admin-rmtree (directory)
 374   "Delete a directory and all of its contents, recursively.
 375 This is a feeble attempt at making a portable rmdir."
 376   (setq directory (file-name-as-directory directory))
 377   (let ((files (directory-files directory nil nil nil t))
 378         (dirs (directory-files directory nil nil nil 'dirs)))
 379     (while dirs
 380       (if (not (member (car dirs) '("." "..")))
 381           (let ((dir (expand-file-name (car dirs) directory)))
 382             (condition-case err
 383                 (if (file-symlink-p dir) ;; just in case, handle symlinks
 384                     (delete-file dir)
 385                   (package-admin-rmtree dir))
 386               (file-error
 387                (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err)))))
 388         (setq dirs (cdr dirs))))
 389     (while files
 390       (condition-case err
 391           (delete-file (expand-file-name (car files) directory))
 392         (file-error
 393          (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))
 394       (setq files (cdr files)))
 395     (condition-case err
 396         (delete-directory directory)
 397       (file-error
 398        (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))))
 399
 400 (defun package-admin-get-lispdir  (pkg-topdir package)
 401   (let (package-lispdir)
 402     (if (and (setq package-lispdir (expand-file-name "lisp" pkg-topdir))
 403              (setq package-lispdir (expand-file-name (symbol-name package)
 404                                                      package-lispdir))
 405              (file-accessible-directory-p package-lispdir))
 406         package-lispdir)
 407     ))
 408
 409 (defun package-admin-delete-binary-package (package pkg-topdir)
 410   "Delete a binary installation of PACKAGE below directory PKG-TOPDIR.
 411 PACKAGE is a symbol, not a string."
 412   (let ( (tmpbuf " *pkg-manifest*") manifest-file package-lispdir dirs file)
 413     (setq pkg-topdir (package-admin-get-install-dir package pkg-topdir))
 414     (setq manifest-file (package-admin-get-manifest-file pkg-topdir package))
 415     (run-hook-with-args 'package-delete-hook package pkg-topdir)
 416     (if (file-exists-p manifest-file)
 417         (progn
 418           ;; The manifest file exists!  Use it to delete the old distribution.
 419           (message "Removing old files for package \"%s\" ..." package)
 420           (sit-for 0)
 421           (setq tmpbuf (get-buffer-create tmpbuf))
 422           (with-current-buffer tmpbuf
 423             (buffer-disable-undo)
 424             (erase-buffer)
 425             (insert-file-contents manifest-file)
 426             (goto-char (point-min))
 427
 428             ;; For each entry in the MANIFEST ...
 429             (while (< (point) (point-max))
 430               (beginning-of-line)
 431               (setq file (expand-file-name (buffer-substring
 432                                             (point)
 433                                             (point-at-eol))
 434                                            pkg-topdir))
 435               (if (file-directory-p file)
 436                   ;; Keep a record of each directory
 437                   (setq dirs (cons file dirs))
 438                   ;; Delete each file.
 439                   ;; Make sure that the file is writable.
 440                   ;; (This is important under MS Windows.)
 441                   ;; I do not know why it important under MS Windows but
 442                   ;;    1. It bombs out when the file does not exist. This can be condition-cased
 443                   ;;    2. If I removed the write permissions, I do not want XEmacs to just ignore them.
 444                   ;;       If it wants to, XEmacs may ask, but that is about all
 445                   ;; (set-file-modes file 438) ;; 438 -> #o666
 446                   ;; Note, user might have removed the file!
 447                 (condition-case ()
 448                     (delete-file file)
 449                   (error nil)))         ;; We may want to turn the error into a Warning?
 450               (forward-line 1))
 451
 452             ;; Delete empty directories.
 453             (if dirs
 454                 (let ( (orig-default-directory default-directory)
 455                        ;; directory files file
 456                        )
 457                   ;; Make sure we preserve the existing `default-directory'.
 458                   ;; JV, why does this change the default directory? Does it indeed?
 459                   (unwind-protect
 460                       (progn
 461                         ;; Warning: destructive sort!
 462                         (setq dirs (nreverse (sort dirs 'string<)))
 463 ;                       ;; For each directory ...
 464 ;                       (while dirs
 465 ;                         (setq directory (file-name-as-directory (car dirs)))
 466 ;                         (setq files (directory-files directory))
 467 ;                         ;; Delete the directory if it's empty.
 468 ;                         (if (catch 'done
 469 ;                               (while files
 470 ;                                 (setq file (car files))
 471 ;                                 (if (and (not (string= file "."))
 472 ;                                          (not (string= file "..")))
 473 ;                                     (throw 'done nil))
 474 ;                                 (setq files (cdr files))
 475 ;                                 )
 476 ;                               t)
 477 ;                             (
 478 ;                             (delete-directory directory))
 479 ;                         (setq dirs (cdr dirs))
 480 ;                         )
 481                         ;; JV, On all OS's that I know of delete-directory fails on
 482                         ;; on non-empty dirs anyway
 483                         (mapc
 484                            (lambda (dir)
 485                              (condition-case ()
 486                                  (delete-directory dir)))
 487                            dirs))
 488                     (setq default-directory orig-default-directory)
 489                     )))
 490             )
 491           (kill-buffer tmpbuf)
 492           ;; Delete the MANIFEST file
 493           ;; (set-file-modes manifest-file 438) ;; 438 -> #o666
 494           ;; Note. Packages can have MANIFEST in MANIFEST.
 495           (condition-case ()
 496               (delete-file manifest-file)
 497             (error nil)) ;; Do warning?
 498           (message "Removing old files for package \"%s\" ... done" package))
 499         ;; The manifest file doesn't exist.  Fallback to just deleting the
 500         ;; package-specific lisp directory, if it exists.
 501         ;;
 502         ;; Delete old lisp directory, if any
 503         ;; Gads, this is ugly.  However, we're not supposed to use `concat'
 504         ;; in the name of portability.
 505         (when (setq package-lispdir (package-admin-get-lispdir pkg-topdir
 506                                                              package))
 507               (message "Removing old lisp directory \"%s\" ..."
 508                        package-lispdir)
 509               (sit-for 0)
 510               (package-admin-rmtree package-lispdir)
 511               (message "Removing old lisp directory \"%s\" ... done"
 512                        package-lispdir)
 513               ))
 514     ;; Delete the package from the database of installed packages.
 515     (package-delete-name package)))
 516
 517 (provide 'package-admin)
 518
 519 ;;; package-admin.el ends here