1 ;;; package-admin.el --- Installation and Maintenance of XEmacs packages
3 ;; Copyright (C) 1997 by Free Software Foundation, Inc.
5 ;; Author: SL Baur <steve@altair.xemacs.org>
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
29 ;; First pass at lisp front end to package maintenance.
35 (defvar package-admin-xemacs (concat invocation-directory invocation-name)
36 "Location of XEmacs binary to use.")
38 (defvar package-admin-temp-buffer "*Package Output*"
39 "Temporary buffer where output of backend commands is saved.")
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
47 (defvar package-admin-error-messages '(
48 "No space left on device"
49 "No such file or directory"
51 "Read-only file system"
58 "Unable to create directory"
59 "Directory checksum error"
60 "Cannot exclusively open file"
65 "invalid compressed data"
66 "too many leaves in Huffman tree"
67 "not a valid zip file"
68 "first entry not deflated or stored"
70 "unexpected end of file"
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
77 This is awful, but it exists because error return codes aren't reliable
80 (defvar package-admin-tar-filename-regexps
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-.*\\)"
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
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-.*\\)"
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-.*\\)"
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
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: ")
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"
121 ;; rest of command line follows
122 package-admin-xemacs file destination)))
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)
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
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)
142 ; (call-process "add-big-package.sh"
146 ; ;; rest of command line follows
147 ; package-admin-xemacs file pkg-dir))
149 (defun package-admin-get-install-dir (package pkg-dir &optional mule-related)
150 "If PKG-DIR is non-nil return that,
151 else return the current location of the package if it is already installed
152 or return a location appropriate for the package otherwise."
155 (let ((package-feature (intern-soft (concat
156 (symbol-name package) "-autoloads")))
158 (when (and (not (eq package 'unknown))
159 (featurep package-feature)
160 (setq autoload-dir (feature-file package-feature))
161 (setq autoload-dir (file-name-directory autoload-dir))
162 (member autoload-dir late-package-load-path))
163 ;; Find the corresonding entry in late-package
165 (car-safe (member-if (lambda (h)
166 (string-match (concat "^" (regexp-quote h))
171 ;; Ok we need to guess
173 (package-admin-get-install-dir 'mule-base nil nil)
174 (car (last late-packages)))))))
178 (defun package-admin-get-manifest-file (pkg-topdir package)
179 "Return the name of the MANIFEST file for package PACKAGE.
180 Note that PACKAGE is a symbol, and not a string."
182 (setq dir (expand-file-name "pkginfo" pkg-topdir))
183 (expand-file-name (concat "MANIFEST." (symbol-name package)) dir)
186 (defun package-admin-check-manifest (pkg-outbuf pkg-topdir)
187 "Check for a MANIFEST.<package> file in the package distribution.
188 If it doesn't exist, create and write one.
189 PKG-OUTBUF is the buffer that holds the output from `tar', and PKG-TOPDIR
190 is the top-level directory under which the package was installed."
191 (let ( (manifest-buf " *pkg-manifest*")
192 old-case-fold-search regexp package-name pathname regexps)
193 ;; Save and restore the case-fold-search status.
194 ;; We do this in case we have to screw with it (as it the case of
195 ;; case-insensitive filesystems such as MS Windows).
196 (setq old-case-fold-search case-fold-search)
198 (save-excursion ;; Probably redundant.
199 (set-buffer (get-buffer pkg-outbuf)) ;; Probably already the
201 (goto-char (point-min))
203 ;; Make filenames case-insensitive, if necessary
204 (if (eq system-type 'windows-nt)
205 (setq case-fold-search t))
207 ;; We really should compute the regexp.
208 ;; However, directory-sep-char is currently broken, but we need
209 ;; functional code *NOW*.
210 (setq regexp "\\bpkginfo[\\/]MANIFEST\\...*")
212 ;; Look for the manifest.
213 (if (not (re-search-forward regexp nil t))
215 ;; We didn't find a manifest. Make one.
217 ;; Yuk. We weren't passed the package name, and so we have
218 ;; to dig for it. Look for it as the subdirectory name below
219 ;; "lisp", "man", "info", or "etc".
220 ;; Here, we don't use a single regexp because we want to search
221 ;; the directories for a package name in a particular order.
222 ;; The problem is that packages could have directories like
223 ;; "etc/sounds/" or "etc/photos/" and we don't want to get
224 ;; these confused with the actual package name (although, in
225 ;; the case of "etc/sounds/", it's probably correct).
227 (let ( (dirs '("lisp" "info" "man" "etc")) rexp)
229 (setq rexp (concat "\\b" (car dirs)
230 "[\\/]\\([^\\/]+\\)[\//]"))
231 (if (re-search-forward rexp nil t)
233 (setq dirs (cdr dirs))
236 (setq package-name (buffer-substring (match-beginning 1)
239 ;; Get and erase the manifest buffer
240 (setq manifest-buf (get-buffer-create manifest-buf))
241 (buffer-disable-undo manifest-buf)
242 (erase-buffer manifest-buf)
244 ;; Now, scan through the output buffer, looking for
245 ;; file and directory names.
246 (goto-char (point-min))
248 (while (< (point) (point-max))
252 ;; scan through the regexps, looking for a pathname
253 (if (catch 'found-path
254 (setq regexps package-admin-tar-filename-regexps)
256 (if (looking-at (car regexps))
262 (throw 'found-path t)
264 (setq regexps (cdr regexps))
268 ;; found a pathname -- add it to the manifest
271 (set-buffer manifest-buf)
272 (goto-char (point-max))
273 (insert pathname "\n")
279 ;; Processed all lines.
280 ;; Now, create the file, pkginfo/MANIFEST.<pkgname>
282 ;; We use `expand-file-name' instead of `concat',
284 (setq pathname (expand-file-name "pkginfo"
286 ;; Create pkginfo, if necessary
287 (if (not (file-directory-p pathname))
288 (make-directory pathname))
289 (setq pathname (expand-file-name
290 (concat "MANIFEST." package-name)
293 (set-buffer manifest-buf)
294 ;; Put the files in sorted order
295 (sort-lines nil (point-min) (point-max))
297 ;; Note that using `write-region' *BYPASSES* any check
298 ;; to see if XEmacs is currently editing/visiting the
300 (write-region (point-min) (point-max) pathname)
302 (kill-buffer manifest-buf)
305 ;; We can't determine the package name from an extracted
306 ;; file in the tar output buffer.
310 ;; Restore old case-fold-search status
311 (setq case-fold-search old-case-fold-search))
315 (defun package-admin-add-binary-package (file &optional pkg-dir)
316 "Install a pre-bytecompiled XEmacs package into package hierarchy."
317 (interactive "fPackage tarball: ")
318 (let ((buf (get-buffer-create package-admin-temp-buffer))
322 (setq pkg-dir (package-admin-get-install-dir 'unknown pkg-dir))
323 ;; Insure that the current directory doesn't change
326 (setq default-directory pkg-dir)
327 (setq case-fold-search t)
328 (buffer-disable-undo)
329 (goto-char (setq start (point-max)))
330 (if (= 0 (setq status (funcall package-admin-install-function
333 ;; First, check for errors.
334 ;; We can't necessarily rely upon process error codes.
337 (setq err-list package-admin-error-messages)
339 (if (re-search-forward (car err-list) nil t)
344 (setq err-list (cdr err-list))
347 ;; Make sure that the MANIFEST file exists
348 (package-admin-check-manifest buf pkg-dir)
354 (defun package-admin-rmtree (directory)
355 "Delete a directory and all of its contents, recursively.
356 This is a feeble attempt at making a portable rmdir."
357 (setq directory (file-name-as-directory directory))
358 (let ((files (directory-files directory nil nil nil t))
359 (dirs (directory-files directory nil nil nil 'dirs)))
361 (if (not (member (car dirs) '("." "..")))
362 (let ((dir (expand-file-name (car dirs) directory)))
364 (if (file-symlink-p dir) ;; just in case, handle symlinks
366 (package-admin-rmtree dir))
368 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err)))))
369 (setq dirs (cdr dirs))))
372 (delete-file (expand-file-name (car files) directory))
374 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))
375 (setq files (cdr files)))
377 (delete-directory directory)
379 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))))
381 (defun package-admin-get-lispdir (pkg-topdir package)
382 (let (package-lispdir)
383 (if (and (setq package-lispdir (expand-file-name "lisp" pkg-topdir))
384 (setq package-lispdir (expand-file-name (symbol-name package)
386 (file-accessible-directory-p package-lispdir))
390 (defun package-admin-delete-binary-package (package pkg-topdir)
391 "Delete a binary installation of PACKAGE below directory PKG-TOPDIR.
392 PACKAGE is a symbol, not a string."
393 (let ( (tmpbuf " *pkg-manifest*") manifest-file package-lispdir dirs file)
394 (setq pkg-topdir (package-admin-get-install-dir package pkg-topdir))
395 (setq manifest-file (package-admin-get-manifest-file pkg-topdir package))
396 (if (file-exists-p manifest-file)
398 ;; The manifest file exists! Use it to delete the old distribution.
399 (message "Removing old files for package \"%s\" ..." package)
401 (setq tmpbuf (get-buffer-create tmpbuf))
402 (with-current-buffer tmpbuf
403 (buffer-disable-undo)
405 (insert-file-contents manifest-file)
406 (goto-char (point-min))
408 ;; For each entry in the MANIFEST ...
409 (while (< (point) (point-max))
411 (setq file (expand-file-name (buffer-substring
415 (if (file-directory-p file)
416 ;; Keep a record of each directory
417 (setq dirs (cons file dirs))
419 ;; Make sure that the file is writable.
420 ;; (This is important under MS Windows.)
421 ;; I do not know why it important under MS Windows but
422 ;; 1. It bombs out out when the file does not exist. This can be condition-cased
423 ;; 2. If I removed the write permissions, I do not want XEmacs to just ignore them.
424 ;; If it wants to, XEmacs may ask, but that is about all
425 ;; (set-file-modes file 438) ;; 438 -> #o666
426 ;; Note, user might have removed the file!
429 (error nil))) ;; We may want to turn the error into a Warning?
432 ;; Delete empty directories.
434 (let ( (orig-default-directory default-directory)
435 ; directory files file
437 ;; Make sure we preserve the existing `default-directory'.
438 ;; JV, why does this change the default directory? Does it indeed?
441 ;; Warning: destructive sort!
442 (setq dirs (nreverse (sort dirs 'string<)))
443 ; ;; For each directory ...
445 ; (setq directory (file-name-as-directory (car dirs)))
446 ; (setq files (directory-files directory))
447 ; ;; Delete the directory if it's empty.
450 ; (setq file (car files))
451 ; (if (and (not (string= file "."))
452 ; (not (string= file "..")))
454 ; (setq files (cdr files))
458 ; (delete-directory directory))
459 ; (setq dirs (cdr dirs))
461 ;; JV, On all OS's that I know of delete-directory fails on
462 ;; on non-empty dirs anyway
466 (delete-directory dir)))
468 (setq default-directory orig-default-directory)
472 ;; Delete the MANIFEST file
473 ;; (set-file-modes manifest-file 438) ;; 438 -> #o666
474 ;; Note. Packages can have MANIFEST in MANIFEST.
476 (delete-file manifest-file)
477 (error nil)) ;; Do warning?
478 (message "Removing old files for package \"%s\" ... done" package))
479 ;; The manifest file doesn't exist. Fallback to just deleting the
480 ;; package-specific lisp directory, if it exists.
482 ;; Delete old lisp directory, if any
483 ;; Gads, this is ugly. However, we're not supposed to use `concat'
484 ;; in the name of portability.
485 (when (setq package-lispdir (package-admin-get-lispdir pkg-topdir
487 (message "Removing old lisp directory \"%s\" ..."
490 (package-admin-rmtree package-lispdir)
491 (message "Removing old lisp directory \"%s\" ... done"
494 ;; Delete the package from the database of installed packages.
495 (package-delete-name package)))
497 (provide 'package-admin)
499 ;;; package-admin.el ends here