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