1 ;;; package-admin.el --- Installation and Maintenance of SXEmacs packages
3 ;; Copyright (C) 1997 by Free Software Foundation, Inc.
4 ;; Copyright (C) 2003, 2004 Steve Youngs.
6 ;; Author: SL Baur <steve@xemacs.org>
9 ;; This file is part of SXEmacs.
11 ;; SXEmacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; SXEmacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
24 ;;; Synched up with: Not in FSF
28 ;; First pass at lisp front end to package maintenance.
34 (defvar package-admin-sxemacs (concat invocation-directory invocation-name)
35 "Location of SXEmacs binary to use.")
37 (defvar package-admin-temp-buffer "*Package Output*"
38 "Temporary buffer where output of backend commands is saved.")
40 (defvar package-admin-install-function 'package-admin-default-install-function
41 "The function to call to install a package.
42 Three args are passed: FILENAME PKG-DIR BUFFER
43 Install package FILENAME into directory PKG-DIR, with any messages output
46 (defvar package-admin-error-messages '(
47 "No space left on device"
48 "No such file or directory"
50 "Read-only file system"
57 "Unable to create directory"
58 "Directory checksum error"
59 "Cannot exclusively open file"
64 "invalid compressed data"
65 "too many leaves in Huffman tree"
66 "not a valid zip file"
67 "first entry not deflated or stored"
69 "unexpected end of file"
71 "Regular expressions of possible error messages.
72 After each package extraction, the `package-admin-temp-buffer' buffer is
73 scanned for these messages. An error code is returned if one of these are
76 This is awful, but it exists because error return codes aren't reliable
79 (defvar package-admin-tar-filename-regexps
82 ;; drwxrwxr-x john/doe 123 1997-02-18 15:48 pathname
83 "\\S-+\\s-+[-a-z0-9_/]+\\s-+[0-9]+\\s-+[-0-9]+\\s-+[0-9:]+\\s-+\\(\\S-.*\\)"
85 ;; rwxrwxr-x 501/501 123 Feb 18 15:46 1997 pathname
86 ;; Solaris tar (phooey!):
87 ;; rwxrwxr-x501/501 123 Feb 18 15:46 1997 pathname
89 ;; -rw-r--r-- 147 1019 32919 Mar 26 12:00:09 1992 pathname
90 "\\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-.*\\)"
93 ;; drwx Aug 31 02:01:41 1998 123 pathname
94 "\\S-+\\s-+[a-z][a-z][a-z]\\s-+[0-9]+\\s-+[0-9:]+\\s-+[0-9]+\\s-+[0-9]+\\s-+\\(\\S-.*\\)"
97 "List of regexps to use to search for tar filenames.
98 Note that \"\\(\" and \"\\)\" must be used to delimit the pathname (as
99 match #1). Don't put \"^\" to match the beginning of the line; this
100 is already implicit, as `looking-at' is used. Filenames can,
101 unfortunately, contain spaces, so be careful in constructing any
104 (defvar package-install-hook nil
105 "*List of hook functions to be called when a new package is successfully
106 installed. The hook function is passed two arguments: the package name, and
107 the install directory.")
109 (defvar package-delete-hook nil
110 "*List of hook functions to be called when a package is deleted. The
111 hook is called *before* the package is deleted. The hook function is passed
112 two arguments: the package name, and the install directory.")
114 (defun package-admin-default-install-function (filename pkg-dir buffer)
115 "Default function to install a package.
116 Install package FILENAME into directory PKG-DIR, with any messages output
118 (let* ((pkg-dir (file-name-as-directory pkg-dir))
119 (default-directory pkg-dir)
120 (filename (expand-file-name filename)))
121 (unless (file-directory-p pkg-dir)
122 (make-directory pkg-dir t))
123 ;; Don't assume GNU tar.
124 (if (shell-command (concat "gunzip -c " filename " | tar xvf -") buffer)
128 ;; A few things needed by the following 2 functions.
131 (autoload 'package-get-info "package-get")
132 (autoload 'paths-decode-directory-path "find-paths")
133 (defvar package-get-install-to-user-init-directory))
135 (defun package-admin-find-top-directory (type &optional user-dir)
136 "Return the top level directory for a package.
138 Argument TYPE is a symbol that determines the type of package we're
139 trying to find a directory for.
141 Optional Argument USER-DIR if non-nil use directories off
142 `user-init-directory'. This overrides everything except
143 \"EMACSPACKAGEPATH\".
145 This function honours the environment variable \"EMACSPACKAGEPATH\"
146 and returns directories found there as a priority. If that variable
147 doesn't exist and USER-DIR is nil, check in the normal places.
149 If we still can't find a suitable directory, return nil.
151 Possible values for TYPE are:
153 sxemacs == For \"sxemacs\" packages that go in '/sxemacs-packages/'
154 std == For \"standard\" packages that go in '/xemacs-packages/'
155 mule == For \"mule\" packages that go in '/mule-packages/'
156 site == For \"unsupported\" packages that go in '/site-packages/'
159 (let* ((env-value (getenv "EMACSPACKAGEPATH"))
161 ;; First, check the environment var.
163 (let ((path-list (paths-decode-directory-path env-value 'drop-empties)))
164 (cond ((eq type 'site)
166 (if (equal (file-name-nondirectory
167 (directory-file-name (car path-list)))
169 (setq top-dir (car path-list)))
170 (setq path-list (cdr path-list))))
173 (if (equal (file-name-nondirectory
174 (directory-file-name (car path-list)))
176 (setq top-dir (car path-list)))
177 (setq path-list (cdr path-list))))
180 (if (equal (file-name-nondirectory
181 (directory-file-name (car path-list)))
183 (setq top-dir (car path-list)))
184 (setq path-list (cdr path-list))))
187 (if (equal (file-name-nondirectory
188 (directory-file-name (car path-list)))
190 (setq top-dir (car path-list)))
191 (setq path-list (cdr path-list)))))))
192 ;; Wasn't in the environment, try `user-init-directory' if
193 ;; USER-DIR is non-nil.
196 (cond ((eq type 'site)
197 (setq top-dir (file-name-as-directory
198 (expand-file-name "site-packages" user-init-directory))))
200 (setq top-dir (file-name-as-directory
201 (expand-file-name "sxemacs-packages" user-init-directory))))
203 (setq top-dir (file-name-as-directory
204 (expand-file-name "xemacs-packages" user-init-directory))))
206 (setq top-dir (file-name-as-directory
207 (expand-file-name "mule-packages" user-init-directory))))))
208 ;; Finally check the normal places
210 (let ((path-list (nth 1 (packages-find-packages
212 (packages-compute-package-locations user-init-directory)))))
213 (cond ((eq type 'site)
215 (if (equal (file-name-nondirectory
216 (directory-file-name (car path-list)))
218 (setq top-dir (car path-list)))
219 (setq path-list (cdr path-list))))
222 (if (equal (file-name-nondirectory
223 (directory-file-name (car path-list)))
225 (setq top-dir (car path-list)))
226 (setq path-list (cdr path-list))))
229 (if (equal (file-name-nondirectory
230 (directory-file-name (car path-list)))
232 (setq top-dir (car path-list)))
233 (setq path-list (cdr path-list))))
236 (if (equal (file-name-nondirectory
237 (directory-file-name (car path-list)))
239 (setq top-dir (car path-list)))
240 (setq path-list (cdr path-list)))))))
241 ;; Now return either the directory or nil.
244 (defun package-admin-get-install-dir (package &optional pkg-dir)
245 "Find a suitable installation directory for a package.
247 Argument PACKAGE is the package to find a installation directory for.
248 Optional Argument PKG-DIR, if non-nil is a directory to use for
251 If PKG-DIR is non-nil and writable, return that. Otherwise check to
252 see if the PACKAGE is already installed and return that location, if
253 it is writable. Finally, fall back to the `user-init-directory' if
254 all else fails. As a side effect of installing packages under
255 `user-init-directory' these packages become part of `early-packages'."
256 ;; If pkg-dir specified, return that if writable.
258 (file-writable-p (directory-file-name pkg-dir)))
260 ;; If the user want her packages under ~/.sxemacs/, do so.
261 (let ((type (package-get-info package 'category)))
262 (if package-get-install-to-user-init-directory
264 (cond ((equal type "site")
265 (setq pkg-dir (package-admin-find-top-directory 'site 'user-dir)))
266 ((equal type "sxemacs")
267 (setq pkg-dir (package-admin-find-top-directory 'sxemacs 'user-dir)))
268 ((equal type "standard")
269 (setq pkg-dir (package-admin-find-top-directory 'std 'user-dir)))
271 (setq pkg-dir (package-admin-find-top-directory 'mule 'user-dir))))
273 ;; Maybe the package has been installed before, if so, return
275 (let ((package-feature (intern-soft (concat
276 (symbol-name package) "-autoloads")))
278 (when (and (not (eq package 'unknown))
279 (featurep package-feature)
280 (setq autoload-dir (feature-file package-feature))
281 (setq autoload-dir (file-name-directory autoload-dir))
282 (member autoload-dir (append early-package-load-path late-package-load-path)))
283 ;; Find the corresponding entry in late-package
285 (car-safe (member-if (lambda (h)
286 (string-match (concat "^" (regexp-quote h))
288 (append (cdr early-packages) late-packages)))))
290 (file-writable-p (directory-file-name pkg-dir)))
292 ;; OK, the package hasn't been previously installed so we need
293 ;; to guess where it should go.
294 (cond ((equal type "site")
295 (setq pkg-dir (package-admin-find-top-directory 'site)))
296 ((equal type "sxemacs")
297 (setq pkg-dir (package-admin-find-top-directory 'sxemacs)))
298 ((equal type "standard")
299 (setq pkg-dir (package-admin-find-top-directory 'std)))
301 (setq pkg-dir (package-admin-find-top-directory 'mule)))
303 (error 'invalid-operation
304 "Invalid package type")))
306 (file-writable-p (directory-file-name pkg-dir)))
308 ;; Oh no! Either we still haven't found a suitable
309 ;; directory, or we can't write to the one we did find.
310 ;; Drop back to the `user-init-directory'.
311 (if (y-or-n-p (format "Directory isn't writable, use %s instead? "
312 user-init-directory))
314 (cond ((equal type "site")
315 (setq pkg-dir (package-admin-find-top-directory 'site 'user-dir)))
316 ((equal type "sxemacs")
317 (setq pkg-dir (package-admin-find-top-directory 'sxemacs 'user-dir)))
318 ((equal type "standard")
319 (setq pkg-dir (package-admin-find-top-directory 'std 'user-dir)))
321 (setq pkg-dir (package-admin-find-top-directory 'mule 'user-dir)))
323 (error 'invalid-operation
324 "Invalid package type")))
325 ;; Turn on `package-get-install-to-user-init-directory'
326 ;; so we don't get asked for each package we try to
327 ;; install in this session.
328 (setq package-get-install-to-user-init-directory t)
330 ;; If we get to here SXEmacs can't make up its mind and
331 ;; neither can the user, nothing left to do except barf. :-(
332 (error 'search-failed
334 "Can't find suitable installation directory for package: %s"
337 (defun package-admin-get-manifest-file (pkg-topdir package)
338 "Return the name of the MANIFEST file for package PACKAGE.
339 Note that PACKAGE is a symbol, and not a string."
340 (let ((dir (file-name-as-directory
341 (expand-file-name "pkginfo" pkg-topdir))))
342 (expand-file-name (concat "MANIFEST." (symbol-name package)) dir)))
344 (defun package-admin-check-manifest (pkg-outbuf pkg-topdir)
345 "Check for a MANIFEST.<package> file in the package distribution.
346 If it doesn't exist, create and write one.
347 PKG-OUTBUF is the buffer that holds the output from `tar', and PKG-TOPDIR
348 is the top-level directory under which the package was installed."
349 (let ((manifest-buf " *pkg-manifest*")
350 (old-case-fold-search case-fold-search)
351 regexp package-name pathname regexps)
353 (save-excursion ;; Probably redundant.
354 (set-buffer (get-buffer pkg-outbuf)) ;; Probably already the current buffer.
355 (goto-char (point-min))
357 ;; Make filenames case-insensitive, if necessary
358 (if (eq system-type 'windows-nt)
359 (setq case-fold-search t))
361 (setq regexp (concat "\\bpkginfo"
362 (char-to-string directory-sep-char)
365 ;; Look for the manifest.
366 (if (not (re-search-forward regexp nil t))
368 ;; We didn't find a manifest. Make one.
370 ;; Yuk. We weren't passed the package name, and so we have
371 ;; to dig for it. Look for it as the subdirectory name below
373 ;; Here, we don't use a single regexp because we want to search
374 ;; the directories for a package name in a particular order.
376 (let ((dirs '("lisp" "man"))
379 (setq rexp (concat "\\b" (car dirs)
380 "[\\/]\\([^\\/]+\\)[\//]"))
381 (if (re-search-forward rexp nil t)
383 (setq dirs (cdr dirs)))))
385 (setq package-name (buffer-substring (match-beginning 1)
388 ;; Get and erase the manifest buffer
389 (setq manifest-buf (get-buffer-create manifest-buf))
390 (buffer-disable-undo manifest-buf)
391 (erase-buffer manifest-buf)
393 ;; Now, scan through the output buffer, looking for
394 ;; file and directory names.
395 (goto-char (point-min))
397 (while (< (point) (point-max))
401 ;; scan through the regexps, looking for a pathname
402 (if (catch 'found-path
403 (setq regexps package-admin-tar-filename-regexps)
405 (if (looking-at (car regexps))
411 (throw 'found-path t)))
412 (setq regexps (cdr regexps))))
414 ;; found a pathname -- add it to the manifest
417 (set-buffer manifest-buf)
418 (goto-char (point-max))
419 (insert pathname "\n"))))
422 ;; Processed all lines.
423 ;; Now, create the file, pkginfo/MANIFEST.<pkgname>
425 ;; We use `expand-file-name' instead of `concat',
427 (setq pathname (expand-file-name "pkginfo"
429 ;; Create pkginfo, if necessary
430 (if (not (file-directory-p pathname))
431 (make-directory pathname))
432 (setq pathname (expand-file-name
433 (concat "MANIFEST." package-name)
436 (set-buffer manifest-buf)
437 ;; Put the files in sorted order
438 (if-fboundp 'sort-lines
439 (sort-lines nil (point-min) (point-max))
440 (warn "`xemacs-base' not installed, MANIFEST.%s not sorted"
443 ;; Note that using `write-region' *BYPASSES* any check
444 ;; to see if SXEmacs is currently editing/visiting the
446 (write-region (point-min) (point-max) pathname))
447 (kill-buffer manifest-buf))))))
448 ;; Restore old case-fold-search status
449 (setq case-fold-search old-case-fold-search))))
452 (defun package-admin-add-binary-package (file &optional pkg-dir)
453 "Install a pre-bytecompiled XEmacs package into package hierarchy."
454 (interactive "fPackage tarball: ")
455 (let ((buf (get-buffer-create package-admin-temp-buffer))
458 (setq pkg-dir (package-admin-get-install-dir 'unknown pkg-dir))
459 ;; Ensure that the current directory doesn't change
462 ;; This is not really needed
463 (setq default-directory (file-name-as-directory pkg-dir))
464 (setq case-fold-search t)
465 (buffer-disable-undo)
466 (goto-char (setq start (point-max)))
467 (if (= 0 (setq status (funcall package-admin-install-function
470 ;; First, check for errors.
471 ;; We can't necessarily rely upon process error codes.
474 (setq err-list package-admin-error-messages)
476 (if (re-search-forward (car err-list) nil t)
480 (setq err-list (cdr err-list))))
481 ;; Make sure that the MANIFEST file exists
482 (package-admin-check-manifest buf pkg-dir))))
485 (defun package-admin-rmtree (directory)
486 "Delete a directory and all of its contents, recursively.
487 This is a feeble attempt at making a portable rmdir."
488 (setq directory (file-name-as-directory directory))
489 (let ((files (directory-files directory nil nil nil t))
490 (dirs (directory-files directory nil nil nil 'dirs)))
492 (if (not (member (car dirs) '("." "..")))
493 (let ((dir (expand-file-name (car dirs) directory)))
495 (if (file-symlink-p dir) ;; just in case, handle symlinks
497 (package-admin-rmtree dir))
499 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err)))))
500 (setq dirs (cdr dirs))))
503 (delete-file (expand-file-name (car files) directory))
505 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))
506 (setq files (cdr files)))
508 (delete-directory directory)
510 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))))
512 (defun package-admin-get-lispdir (pkg-topdir package)
513 (let (package-lispdir)
514 (if (and (setq package-lispdir (expand-file-name "lisp" pkg-topdir))
515 (setq package-lispdir (expand-file-name (symbol-name package)
517 (file-accessible-directory-p package-lispdir))
520 (defun package-admin-delete-binary-package (package pkg-topdir)
521 "Delete a binary installation of PACKAGE below directory PKG-TOPDIR.
522 PACKAGE is a symbol, not a string."
523 (let (manifest-file package-lispdir dirs file)
524 (setq pkg-topdir (package-admin-get-install-dir package pkg-topdir))
525 (setq manifest-file (package-admin-get-manifest-file pkg-topdir package))
526 (run-hook-with-args 'package-delete-hook package pkg-topdir)
527 (if (file-exists-p manifest-file)
529 ;; The manifest file exists! Use it to delete the old distribution.
530 (message "Removing old files for package \"%s\" ..." package)
533 (buffer-disable-undo)
535 (insert-file-contents manifest-file)
536 (goto-char (point-min))
538 ;; For each entry in the MANIFEST ...
539 (while (< (point) (point-max))
541 (setq file (expand-file-name (buffer-substring
545 (if (file-directory-p file)
546 ;; Keep a record of each directory
547 (setq dirs (cons file dirs))
549 ;; Make sure that the file is writable.
550 ;; (This is important under MS Windows.)
551 ;; I do not know why it important under MS Windows but
552 ;; 1. It bombs out when the file does not exist. This can be condition-cased
553 ;; 2. If I removed the write permissions, I do not want SXEmacs to just ignore them.
554 ;; If it wants to, SXEmacs may ask, but that is about all
555 ;; (set-file-modes file 438) ;; 438 -> #o666
556 ;; Note, user might have removed the file!
559 (error nil))) ;; We may want to turn the error into a Warning?
562 ;; Delete empty directories.
568 (delete-directory dir)))
570 ;; Delete the MANIFEST file
571 ;; (set-file-modes manifest-file 438) ;; 438 -> #o666
572 ;; Note. Packages can have MANIFEST in MANIFEST.
574 (delete-file manifest-file)
575 (error nil)) ;; Do warning?
576 (message "Removing old files for package \"%s\" ... done" package)))
577 ;; The manifest file doesn't exist. Fallback to just deleting the
578 ;; package-specific lisp directory, if it exists.
580 ;; Delete old lisp directory, if any
581 ;; Gads, this is ugly. However, we're not supposed to use `concat'
582 ;; in the name of portability.
583 (setq package-lispdir (package-admin-get-lispdir pkg-topdir package))
584 (when package-lispdir
585 (message "Removing old lisp directory \"%s\" ..." package-lispdir)
587 (package-admin-rmtree package-lispdir)
588 (message "Removing old lisp directory \"%s\" ... done" package-lispdir)))
589 ;; Delete the package from the database of installed packages.
590 (package-delete-name package)))
592 (provide 'package-admin)
594 ;;; package-admin.el ends here