This commit was manufactured by cvs2svn to create tag 'r21-4-22-chise-
[chise/xemacs-chise.git.1] / 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 ;; Copyright (C) 2003, Steve Youngs.
5
6 ;; Author: SL Baur <steve@xemacs.org>
7 ;; Keywords: internal
8
9 ;; This file is part of XEmacs.
10
11 ;; XEmacs is free software; you can redistribute it and/or modify it
12 ;; under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
15
16 ;; XEmacs is distributed in the hope that it will be useful, but
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
19 ;; General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
24 ;; 02111-1307, USA.
25
26 ;;; Synched up with: Not in FSF
27
28 ;;; Commentary:
29
30 ;; First pass at lisp front end to package maintenance.
31
32 ;;; Code:
33
34 (require 'config)
35
36 (defvar package-admin-xemacs (concat invocation-directory invocation-name)
37   "Location of XEmacs binary to use.")
38
39 (defvar package-admin-temp-buffer "*Package Output*"
40   "Temporary buffer where output of backend commands is saved.")
41
42 (defvar package-admin-install-function (if (eq system-type 'windows-nt)
43                                            'package-admin-install-function-mswindows
44                                          'package-admin-default-install-function)
45   "The function to call to install a package.
46 Three args are passed: FILENAME PKG-DIR BUFFER
47 Install package FILENAME into directory PKG-DIR, with any messages output
48 to buffer BUFFER.")
49
50 (defvar package-admin-error-messages '(
51                                        "No space left on device"
52                                        "No such file or directory"
53                                        "Filename too long"
54                                        "Read-only file system"
55                                        "File too large"
56                                        "Too many open files"
57                                        "Not enough space"
58                                        "Permission denied"
59                                        "Input/output error"
60                                        "Out of memory"
61                                        "Unable to create directory"
62                                        "Directory checksum error"
63                                        "Cannot exclusively open file"
64                                        "corrupted file"
65                                        "incomplete .* tree"
66                                        "Bad table"
67                                        "corrupt input"
68                                        "invalid compressed data"
69                                        "too many leaves in Huffman tree"
70                                        "not a valid zip file"
71                                        "first entry not deflated or stored"
72                                        "encrypted file --"
73                                        "unexpected end of file"
74                                        )
75   "Regular expressions of possible error messages.
76 After each package extraction, the `package-admin-temp-buffer' buffer is
77 scanned for these messages.  An error code is returned if one of these are
78 found.
79
80 This is awful, but it exists because error return codes aren't reliable
81 under MS Windows.")
82
83 (defvar package-admin-tar-filename-regexps
84   '(
85     ;; GNU tar:
86     ;; drwxrwxr-x john/doe 123 1997-02-18 15:48 pathname
87     "\\S-+\\s-+[-a-z0-9_/]+\\s-+[0-9]+\\s-+[-0-9]+\\s-+[0-9:]+\\s-+\\(\\S-.*\\)"
88     ;; HP-UX & SunOS tar:
89     ;; rwxrwxr-x 501/501    123 Feb 18 15:46 1997 pathname
90     ;; Solaris tar (phooey!):
91     ;; rwxrwxr-x501/501    123 Feb 18 15:46 1997 pathname
92     ;; AIX tar:
93     ;; -rw-r--r-- 147 1019   32919 Mar 26 12:00:09 1992 pathname
94     "\\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-.*\\)"
95
96     ;; djtar:
97     ;; drwx Aug 31 02:01:41 1998       123 pathname
98     "\\S-+\\s-+[a-z][a-z][a-z]\\s-+[0-9]+\\s-+[0-9:]+\\s-+[0-9]+\\s-+[0-9]+\\s-+\\(\\S-.*\\)"
99
100     )
101   "List of regexps to use to search for tar filenames.
102 Note that \"\\(\" and \"\\)\" must be used to delimit the pathname (as
103 match #1).  Don't put \"^\" to match the beginning of the line; this
104 is already implicit, as `looking-at' is used.  Filenames can,
105 unfortunately, contain spaces, so be careful in constructing any
106 regexps.")
107
108 (defvar package-install-hook nil
109   "*List of hook functions to be called when a new package is successfully
110 installed. The hook function is passed two arguments: the package name, and
111 the install directory.")
112
113 (defvar package-delete-hook nil
114   "*List of hook functions to be called when a package is deleted. The
115 hook is called *before* the package is deleted. The hook function is passed
116 two arguments: the package name, and the install directory.")
117
118 (defun package-admin-install-function-mswindows (file pkg-dir buffer)
119   "Install function for mswindows."
120   (let ((default-directory (file-name-as-directory pkg-dir)))
121     (unless (file-directory-p default-directory)
122       (make-directory default-directory t))
123     (call-process "minitar" nil buffer t file)))
124
125 (defun package-admin-default-install-function (filename pkg-dir buffer)
126   "Default function to install a package.
127 Install package FILENAME into directory PKG-DIR, with any messages output
128 to BUFFER."
129   (let* ((pkg-dir (file-name-as-directory pkg-dir))
130          (default-directory pkg-dir)
131          (filename (expand-file-name filename)))
132     (unless (file-directory-p pkg-dir)
133       (make-directory pkg-dir t))
134     ;; Don't assume GNU tar.
135     (if (shell-command (concat "gunzip -c " filename " | tar xvf -") buffer)
136         0
137       1)))
138
139 ;; A few things needed by the following 2 functions.
140 (eval-when-compile
141   (require 'packages)
142   (autoload 'package-get-info "package-get")
143   (autoload 'paths-decode-directory-path "find-paths")
144   (defvar package-get-install-to-user-init-directory))
145
146 (defun package-admin-find-top-directory (type &optional user-dir)
147   "Return the top level directory for a package.
148
149 Argument TYPE is a symbol that determines the type of package we're
150 trying to find a directory for.
151
152 Optional Argument USER-DIR if non-nil use directories off
153 `user-init-directory'.  This overrides everything except
154 \"EMACSPACKAGEPATH\".
155
156 This function honours the environment variable \"EMACSPACKAGEPATH\"
157 and returns directories found there as a priority.  If that variable
158 doesn't exist and USER-DIR is nil, check in the normal places.
159
160 If we still can't find a suitable directory, return nil.
161
162 Possible values for TYPE are:
163
164     std  == For \"standard\" packages that go in '/xemacs-packages/'
165     mule == For \"mule\" packages that go in '/mule-packages/'
166     site == For \"unsupported\" packages that go in '/site-packages/'
167
168 Note:  Type \"site\" is not yet fully supported."
169   (let* ((env-value (getenv "EMACSPACKAGEPATH"))
170          top-dir)
171     ;; First, check the environment var.
172     (if env-value
173         (let ((path-list (paths-decode-directory-path env-value 'drop-empties)))
174           (cond ((eq type 'std)
175                  (while path-list
176                    (if (equal (file-name-nondirectory 
177                                (directory-file-name (car path-list)))
178                               "xemacs-packages")
179                        (setq top-dir (car path-list)))
180                    (setq path-list (cdr path-list))))
181                 ((eq type 'mule)
182                  (while path-list
183                    (if (equal (file-name-nondirectory 
184                                (directory-file-name (car path-list)))
185                               "mule-packages")
186                        (setq top-dir (car path-list)))
187                    (setq path-list (cdr path-list)))))))
188     ;; Wasn't in the environment, try `user-init-directory' if
189     ;; USER-DIR is non-nil.
190     (if (and user-dir
191              (not top-dir))
192         (cond ((eq type 'std)
193                (setq top-dir (file-name-as-directory
194                               (expand-file-name "xemacs-packages" user-init-directory))))
195               ((eq type 'mule)
196                (setq top-dir (file-name-as-directory
197                               (expand-file-name "mule-packages" user-init-directory))))))
198     ;; Finally check the normal places
199     (if (not top-dir)
200         (let ((path-list (nth 1 (packages-find-packages
201                                  emacs-roots
202                                  (packages-compute-package-locations user-init-directory)))))
203           (cond ((eq type 'std)
204                  (while path-list
205                    (if (equal (file-name-nondirectory 
206                                (directory-file-name (car path-list)))
207                               "xemacs-packages")
208                        (setq top-dir (car path-list)))
209                    (setq path-list (cdr path-list))))
210                 ((eq type 'mule)
211                  (while path-list
212                    (if (equal (file-name-nondirectory 
213                                (directory-file-name (car path-list)))
214                               "mule-packages")
215                        (setq top-dir (car path-list)))
216                    (setq path-list (cdr path-list)))))))
217     ;; Now return either the directory or nil.
218     top-dir))
219
220 (defun package-admin-get-install-dir (package &optional pkg-dir)
221   "Find a suitable installation directory for a package.
222
223 Argument PACKAGE is the package to find a installation directory for.
224 Optional Argument PKG-DIR, if non-nil is a directory to use for
225 installation.
226
227 If PKG-DIR is non-nil and writable, return that.  Otherwise check to
228 see if the PACKAGE is already installed and return that location, if
229 it is writable.  Finally, fall back to the `user-init-directory' if
230 all else fails.  As a side effect of installing packages under
231 `user-init-directory' these packages become part of `early-packages'."
232   ;; If pkg-dir specified, return that if writable.
233   (if (and pkg-dir
234            (file-writable-p (directory-file-name pkg-dir)))
235       pkg-dir
236     ;; If the user want her packages under ~/.xemacs/, do so.
237     (let ((type (package-get-info package 'category)))
238       (if package-get-install-to-user-init-directory
239           (progn
240             (cond ((equal type "standard")
241                    (setq pkg-dir (package-admin-find-top-directory 'std 'user-dir)))
242                   ((equal type "mule")
243                    (setq pkg-dir (package-admin-find-top-directory 'mule 'user-dir))))
244             pkg-dir)
245         ;; Maybe the package has been installed before, if so, return
246         ;; that directory.
247         (let ((package-feature (intern-soft (concat
248                                              (symbol-name package) "-autoloads")))
249               autoload-dir)
250           (when (and (not (eq package 'unknown))
251                      (featurep package-feature)
252                      (setq autoload-dir (feature-file package-feature))
253                      (setq autoload-dir (file-name-directory autoload-dir))
254                      (member autoload-dir (append early-package-load-path late-package-load-path)))
255             ;; Find the corresponding entry in late-package
256             (setq pkg-dir
257                   (car-safe (member-if (lambda (h)
258                                          (string-match (concat "^" (regexp-quote h))
259                                                        autoload-dir))
260                                        (append (cdr early-packages) late-packages)))))
261           (if (and pkg-dir
262                    (file-writable-p (directory-file-name pkg-dir)))
263               pkg-dir
264             ;; OK, the package hasn't been previously installed so we need
265             ;; to guess where it should go.
266             (cond ((equal type "standard")
267                    (setq pkg-dir (package-admin-find-top-directory 'std)))
268                   ((equal type "mule")
269                    (setq pkg-dir (package-admin-find-top-directory 'mule)))
270                   (t
271                    (error 'invalid-operation
272                           "Invalid package type")))
273             (if (and pkg-dir
274                      (file-writable-p (directory-file-name pkg-dir)))
275                 pkg-dir
276               ;; Oh no!  Either we still haven't found a suitable
277               ;; directory, or we can't write to the one we did find.
278               ;; Drop back to the `user-init-directory'.
279               (if (y-or-n-p (format "Directory isn't writable, use %s instead? "
280                                     user-init-directory))
281                   (progn
282                     (cond ((equal type "standard")
283                            (setq pkg-dir (package-admin-find-top-directory 'std 'user-dir)))
284                           ((equal type "mule")
285                            (setq pkg-dir (package-admin-find-top-directory 'mule 'user-dir)))
286                           (t
287                            (error 'invalid-operation
288                                   "Invalid package type")))
289                     ;; Turn on `package-get-install-to-user-init-directory'
290                     ;; so we don't get asked for each package we try to
291                     ;; install in this session.
292                     (setq package-get-install-to-user-init-directory t)
293                     pkg-dir)
294                 ;; If we get to here XEmacs can't make up its mind and
295                 ;; neither can the user, nothing left to do except barf. :-(
296                 (error 'search-failed
297                        (format
298                         "Can't find suitable installation directory for package: %s" 
299                         package))))))))))
300
301 (defun package-admin-get-manifest-file (pkg-topdir package)
302   "Return the name of the MANIFEST file for package PACKAGE.
303 Note that PACKAGE is a symbol, and not a string."
304   (let ((dir (file-name-as-directory
305               (expand-file-name "pkginfo" pkg-topdir))))
306     (expand-file-name (concat "MANIFEST." (symbol-name package)) dir)))
307
308 (defun package-admin-check-manifest (pkg-outbuf pkg-topdir)
309   "Check for a MANIFEST.<package> file in the package distribution.
310 If it doesn't exist, create and write one.
311 PKG-OUTBUF is the buffer that holds the output from `tar', and PKG-TOPDIR
312 is the top-level directory under which the package was installed."
313   (let ((manifest-buf " *pkg-manifest*")
314         (old-case-fold-search case-fold-search)
315         regexp package-name pathname regexps)
316     (unwind-protect
317         (save-excursion                         ;; Probably redundant.
318           (set-buffer (get-buffer pkg-outbuf))  ;; Probably already the current buffer.
319           (goto-char (point-min))
320
321           ;; Make filenames case-insensitive, if necessary
322           (if (eq system-type 'windows-nt)
323               (setq case-fold-search t))
324
325           (setq regexp (concat "\\bpkginfo" 
326                                (char-to-string directory-sep-char)
327                                "MANIFEST\\...*"))
328
329           ;; Look for the manifest.
330           (if (not (re-search-forward regexp nil t))
331               (progn
332                 ;; We didn't find a manifest.  Make one.
333
334                 ;; Yuk.  We weren't passed the package name, and so we have
335                 ;; to dig for it.  Look for it as the subdirectory name below
336                 ;; "lisp", or "man".
337                 ;; Here, we don't use a single regexp because we want to search
338                 ;; the directories for a package name in a particular order.
339                 (if (catch 'done
340                       (let ((dirs '("lisp" "man")) 
341                             rexp)
342                         (while dirs
343                           (setq rexp (concat "\\b" (car dirs)
344                                              "[\\/]\\([^\\/]+\\)[\//]"))
345                           (if (re-search-forward rexp nil t)
346                               (throw 'done t))
347                           (setq dirs (cdr dirs)))))
348                     (progn
349                       (setq package-name (buffer-substring (match-beginning 1)
350                                                            (match-end 1)))
351
352                       ;; Get and erase the manifest buffer
353                       (setq manifest-buf (get-buffer-create manifest-buf))
354                       (buffer-disable-undo manifest-buf)
355                       (erase-buffer manifest-buf)
356
357                       ;; Now, scan through the output buffer, looking for
358                       ;; file and directory names.
359                       (goto-char (point-min))
360                       ;; for each line ...
361                       (while (< (point) (point-max))
362                         (beginning-of-line)
363                         (setq pathname nil)
364
365                         ;; scan through the regexps, looking for a pathname
366                         (if (catch 'found-path
367                               (setq regexps package-admin-tar-filename-regexps)
368                               (while regexps
369                                 (if (looking-at (car regexps))
370                                     (progn
371                                       (setq pathname
372                                             (buffer-substring
373                                              (match-beginning 1)
374                                              (match-end 1)))
375                                       (throw 'found-path t)))
376                                 (setq regexps (cdr regexps))))
377                             (progn
378                               ;; found a pathname -- add it to the manifest
379                               ;; buffer
380                               (save-excursion
381                                 (set-buffer manifest-buf)
382                                 (goto-char (point-max))
383                                 (insert pathname "\n"))))
384                         (forward-line 1))
385
386                       ;; Processed all lines.
387                       ;; Now, create the file, pkginfo/MANIFEST.<pkgname>
388
389                       ;; We use `expand-file-name' instead of `concat',
390                       ;; for portability.
391                       (setq pathname (expand-file-name "pkginfo"
392                                                        pkg-topdir))
393                       ;; Create pkginfo, if necessary
394                       (if (not (file-directory-p pathname))
395                           (make-directory pathname))
396                       (setq pathname (expand-file-name
397                                       (concat "MANIFEST." package-name)
398                                       pathname))
399                       (save-excursion
400                         (set-buffer manifest-buf)
401                         ;; Put the files in sorted order
402                         (if (fboundp 'sort-lines)
403                             (sort-lines nil (point-min) (point-max))
404                           (warn "`xemacs-base' not installed, MANIFEST.%s not sorted"
405                                 package-name))
406                         ;; Write the file.
407                         ;; Note that using `write-region' *BYPASSES* any check
408                         ;; to see if XEmacs is currently editing/visiting the
409                         ;; file.
410                         (write-region (point-min) (point-max) pathname))
411                       (kill-buffer manifest-buf))))))
412       ;; Restore old case-fold-search status
413       (setq case-fold-search old-case-fold-search))))
414
415 ;;;###autoload
416 (defun package-admin-add-binary-package (file &optional pkg-dir)
417   "Install a pre-bytecompiled XEmacs package into package hierarchy."
418   (interactive "fPackage tarball: ")
419   (let ((buf (get-buffer-create package-admin-temp-buffer))
420         (status 1)
421         start err-list)
422     (setq pkg-dir (package-admin-get-install-dir 'unknown pkg-dir))
423     ;; Ensure that the current directory doesn't change
424     (save-excursion
425       (set-buffer buf)
426       ;; This is not really needed
427       (setq default-directory (file-name-as-directory pkg-dir))
428       (setq case-fold-search t)
429       (buffer-disable-undo)
430       (goto-char (setq start (point-max)))
431       (if (= 0 (setq status (funcall package-admin-install-function
432                                      file pkg-dir buf)))
433           (progn
434             ;; First, check for errors.
435             ;; We can't necessarily rely upon process error codes.
436             (catch 'done
437               (goto-char start)
438               (setq err-list package-admin-error-messages)
439               (while err-list
440                 (if (re-search-forward (car err-list) nil t)
441                     (progn
442                       (setq status 1)
443                       (throw 'done nil)))
444                 (setq err-list (cdr err-list))))
445             ;; Make sure that the MANIFEST file exists
446             (package-admin-check-manifest buf pkg-dir))))
447     status))
448
449 (defun package-admin-rmtree (directory)
450   "Delete a directory and all of its contents, recursively.
451 This is a feeble attempt at making a portable rmdir."
452   (setq directory (file-name-as-directory directory))
453   (let ((files (directory-files directory nil nil nil t))
454         (dirs (directory-files directory nil nil nil 'dirs)))
455     (while dirs
456       (if (not (member (car dirs) '("." "..")))
457           (let ((dir (expand-file-name (car dirs) directory)))
458             (condition-case err
459                 (if (file-symlink-p dir) ;; just in case, handle symlinks
460                     (delete-file dir)
461                   (package-admin-rmtree dir))
462               (file-error
463                (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err)))))
464         (setq dirs (cdr dirs))))
465     (while files
466       (condition-case err
467           (delete-file (expand-file-name (car files) directory))
468         (file-error
469          (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))
470       (setq files (cdr files)))
471     (condition-case err
472         (delete-directory directory)
473       (file-error
474        (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))))
475
476 (defun package-admin-get-lispdir  (pkg-topdir package)
477   (let (package-lispdir)
478     (if (and (setq package-lispdir (expand-file-name "lisp" pkg-topdir))
479              (setq package-lispdir (expand-file-name (symbol-name package)
480                                                      package-lispdir))
481              (file-accessible-directory-p package-lispdir))
482         package-lispdir)))
483
484 (defun package-admin-delete-binary-package (package pkg-topdir)
485   "Delete a binary installation of PACKAGE below directory PKG-TOPDIR.
486 PACKAGE is a symbol, not a string."
487   (let (manifest-file package-lispdir dirs file)
488     (setq pkg-topdir (package-admin-get-install-dir package pkg-topdir))
489     (setq manifest-file (package-admin-get-manifest-file pkg-topdir package))
490     (run-hook-with-args 'package-delete-hook package pkg-topdir)
491     (if (file-exists-p manifest-file)
492         (progn
493           ;; The manifest file exists!  Use it to delete the old distribution.
494           (message "Removing old files for package \"%s\" ..." package)
495           (sit-for 0)
496           (with-temp-buffer
497             (buffer-disable-undo)
498             (erase-buffer)
499             (insert-file-contents manifest-file)
500             (goto-char (point-min))
501
502             ;; For each entry in the MANIFEST ...
503             (while (< (point) (point-max))
504               (beginning-of-line)
505               (setq file (expand-file-name (buffer-substring
506                                             (point)
507                                             (point-at-eol))
508                                            pkg-topdir))
509               (if (file-directory-p file)
510                   ;; Keep a record of each directory
511                   (setq dirs (cons file dirs))
512                   ;; Delete each file.
513                   ;; Make sure that the file is writable.
514                   ;; (This is important under MS Windows.)
515                   ;; I do not know why it important under MS Windows but
516                   ;;    1. It bombs out when the file does not exist. This can be condition-cased
517                   ;;    2. If I removed the write permissions, I do not want XEmacs to just ignore them.
518                   ;;       If it wants to, XEmacs may ask, but that is about all
519                   ;; (set-file-modes file 438) ;; 438 -> #o666
520                   ;; Note, user might have removed the file!
521                 (condition-case ()
522                     (delete-file file)
523                   (error nil)))         ;; We may want to turn the error into a Warning?
524               (forward-line 1))
525
526             ;; Delete empty directories.
527             (if dirs
528                 (progn
529                   (mapc
530                    (lambda (dir)
531                      (condition-case ()
532                          (delete-directory dir)))
533                    dirs)))
534           ;; Delete the MANIFEST file
535           ;; (set-file-modes manifest-file 438) ;; 438 -> #o666
536           ;; Note. Packages can have MANIFEST in MANIFEST.
537           (condition-case ()
538               (delete-file manifest-file)
539             (error nil)) ;; Do warning?
540           (message "Removing old files for package \"%s\" ... done" package)))
541       ;; The manifest file doesn't exist.  Fallback to just deleting the
542       ;; package-specific lisp directory, if it exists.
543       ;;
544       ;; Delete old lisp directory, if any
545       ;; Gads, this is ugly.  However, we're not supposed to use `concat'
546       ;; in the name of portability.
547       (setq package-lispdir (package-admin-get-lispdir pkg-topdir package))
548       (when package-lispdir
549         (message "Removing old lisp directory \"%s\" ..." package-lispdir)
550         (sit-for 0)
551         (package-admin-rmtree package-lispdir)
552         (message "Removing old lisp directory \"%s\" ... done" package-lispdir)))
553     ;; Delete the package from the database of installed packages.
554     (package-delete-name package)))
555
556 (provide 'package-admin)
557
558 ;;; package-admin.el ends here