Mercurial > hg > xemacs-beta

comparison lisp/package-admin.el @ 371:cc15677e0335 r21-2b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2b1
author cvs
date Mon, 13 Aug 2007 11:03:08 +0200
parents a4f53d9b3154
children 6240c7796c7a
comparison
equal deleted inserted replaced
370:bd866891f083 371:cc15677e0335
36 "Location of XEmacs binary to use.") 36 "Location of XEmacs binary to use.")
37 37
38 (defvar package-admin-temp-buffer "*Package Output*" 38 (defvar package-admin-temp-buffer "*Package Output*"
39 "Temporary buffer where output of backend commands is saved.") 39 "Temporary buffer where output of backend commands is saved.")
40 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 BUF
46 Install package FILENAME into directory PKG-DIR, with any messages output
47 to buffer BUF.")
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 ;;;###autoload 41 ;;;###autoload
108 (defun package-admin-add-single-file-package (file destdir &optional pkg-dir) 42 (defun package-admin-add-single-file-package (file destdir &optional pkg-dir)
109 "Install a single file Lisp package into XEmacs package hierarchy. 43 "Install a single file Lisp package into XEmacs package hierarchy.
110 `file' should be the full path to the lisp file to install. 44 `file' should be the full path to the lisp file to install.
111 `destdir' should be a simple directory name. 45 `destdir' should be a simple directory name.
121 buf 55 buf
122 t 56 t
123 ;; rest of command line follows 57 ;; rest of command line follows
124 package-admin-xemacs file destination))) 58 package-admin-xemacs file destination)))
125 59
126 (defun package-admin-install-function-mswindows (file pkg-dir buf)
127 "Install function for mswindows"
128 (let ((default-directory (file-name-as-directory pkg-dir)))
129 (unless (file-directory-p default-directory)
130 (make-directory default-directory t))
131 (call-process "minitar" nil buf t file)))
132
133 (defun package-admin-default-install-function (file pkg-dir buf)
134 "Default function to install a package.
135 Install package FILENAME into directory PKG-DIR, with any messages output
136 to buffer BUF."
137 (let* ((pkg-dir (file-name-as-directory pkg-dir))
138 (default-directory pkg-dir)
139 (filename (expand-file-name file)))
140 (unless (file-directory-p pkg-dir)
141 (make-directory pkg-dir t))
142 ;; Don't assume GNU tar.
143 (if (shell-command (concat "gunzip -c " filename " | tar xvf -") buf)
144 0
145 1)
146 ))
147
148 ; (call-process "add-big-package.sh"
149 ; nil
150 ; buf
151 ; t
152 ; ;; rest of command line follows
153 ; package-admin-xemacs file pkg-dir))
154
155 (defun package-admin-get-install-dir (package pkg-dir &optional mule-related)
156 "If PKG-DIR is non-nil return that,
157 else return the current location of the package if it is already installed
158 or return a location appropriate for the package otherwise."
159 (if pkg-dir
160 pkg-dir
161 (let ((package-feature (intern-soft (concat
162 (symbol-name package) "-autoloads")))
163 autoload-dir)
164 (when (and (not (eq package 'unknown))
165 (featurep package-feature)
166 (setq autoload-dir (feature-file package-feature))
167 (setq autoload-dir (file-name-directory autoload-dir))
168 (member autoload-dir (append early-package-load-path late-package-load-path)))
169 ;; Find the corresonding entry in late-package
170 (setq pkg-dir
171 (car-safe (member-if (lambda (h)
172 (string-match (concat "^" (regexp-quote h))
173 autoload-dir))
174 (append (cdr early-packages) late-packages)))))
175 (if pkg-dir
176 pkg-dir
177 ;; Ok we need to guess
178 (if mule-related
179 (package-admin-get-install-dir 'mule-base nil nil)
180 (if (eq package 'xemacs-base)
181 (car (last late-packages))
182 (package-admin-get-install-dir 'xemacs-base nil nil)))))))
183
184
185
186 (defun package-admin-get-manifest-file (pkg-topdir package)
187 "Return the name of the MANIFEST file for package PACKAGE.
188 Note that PACKAGE is a symbol, and not a string."
189 (let (dir)
190 (setq dir (expand-file-name "pkginfo" pkg-topdir))
191 (expand-file-name (concat "MANIFEST." (symbol-name package)) dir)
192 ))
193
194 (defun package-admin-check-manifest (pkg-outbuf pkg-topdir)
195 "Check for a MANIFEST.<package> file in the package distribution.
196 If it doesn't exist, create and write one.
197 PKG-OUTBUF is the buffer that holds the output from `tar', and PKG-TOPDIR
198 is the top-level directory under which the package was installed."
199 (let ( (manifest-buf " *pkg-manifest*")
200 old-case-fold-search regexp package-name pathname regexps)
201 ;; Save and restore the case-fold-search status.
202 ;; We do this in case we have to screw with it (as it the case of
203 ;; case-insensitive filesystems such as MS Windows).
204 (setq old-case-fold-search case-fold-search)
205 (unwind-protect
206 (save-excursion ;; Probably redundant.
207 (set-buffer (get-buffer pkg-outbuf)) ;; Probably already the
208 ;; current buffer.
209 (goto-char (point-min))
210
211 ;; Make filenames case-insensitive, if necessary
212 (if (eq system-type 'windows-nt)
213 (setq case-fold-search t))
214
215 ;; We really should compute the regexp.
216 ;; However, directory-sep-char is currently broken, but we need
217 ;; functional code *NOW*.
218 (setq regexp "\\bpkginfo[\\/]MANIFEST\\...*")
219
220 ;; Look for the manifest.
221 (if (not (re-search-forward regexp nil t))
222 (progn
223 ;; We didn't find a manifest. Make one.
224
225 ;; Yuk. We weren't passed the package name, and so we have
226 ;; to dig for it. Look for it as the subdirectory name below
227 ;; "lisp", "man", "info", or "etc".
228 ;; Here, we don't use a single regexp because we want to search
229 ;; the directories for a package name in a particular order.
230 ;; The problem is that packages could have directories like
231 ;; "etc/sounds/" or "etc/photos/" and we don't want to get
232 ;; these confused with the actual package name (although, in
233 ;; the case of "etc/sounds/", it's probably correct).
234 (if (catch 'done
235 (let ( (dirs '("lisp" "info" "man" "etc")) rexp)
236 (while dirs
237 (setq rexp (concat "\\b" (car dirs)
238 "[\\/]\\([^\\/]+\\)[\//]"))
239 (if (re-search-forward rexp nil t)
240 (throw 'done t))
241 (setq dirs (cdr dirs))
242 )))
243 (progn
244 (setq package-name (buffer-substring (match-beginning 1)
245 (match-end 1)))
246
247 ;; Get and erase the manifest buffer
248 (setq manifest-buf (get-buffer-create manifest-buf))
249 (buffer-disable-undo manifest-buf)
250 (erase-buffer manifest-buf)
251
252 ;; Now, scan through the output buffer, looking for
253 ;; file and directory names.
254 (goto-char (point-min))
255 ;; for each line ...
256 (while (< (point) (point-max))
257 (beginning-of-line)
258 (setq pathname nil)
259
260 ;; scan through the regexps, looking for a pathname
261 (if (catch 'found-path
262 (setq regexps package-admin-tar-filename-regexps)
263 (while regexps
264 (if (looking-at (car regexps))
265 (progn
266 (setq pathname
267 (buffer-substring
268 (match-beginning 1)
269 (match-end 1)))
270 (throw 'found-path t)
271 ))
272 (setq regexps (cdr regexps))
273 )
274 )
275 (progn
276 ;; found a pathname -- add it to the manifest
277 ;; buffer
278 (save-excursion
279 (set-buffer manifest-buf)
280 (goto-char (point-max))
281 (insert pathname "\n")
282 )
283 ))
284 (forward-line 1)
285 )
286
287 ;; Processed all lines.
288 ;; Now, create the file, pkginfo/MANIFEST.<pkgname>
289
290 ;; We use `expand-file-name' instead of `concat',
291 ;; for portability.
292 (setq pathname (expand-file-name "pkginfo"
293 pkg-topdir))
294 ;; Create pkginfo, if necessary
295 (if (not (file-directory-p pathname))
296 (make-directory pathname))
297 (setq pathname (expand-file-name
298 (concat "MANIFEST." package-name)
299 pathname))
300 (save-excursion
301 (set-buffer manifest-buf)
302 ;; Put the files in sorted order
303 (sort-lines nil (point-min) (point-max))
304 ;; Write the file.
305 ;; Note that using `write-region' *BYPASSES* any check
306 ;; to see if XEmacs is currently editing/visiting the
307 ;; file.
308 (write-region (point-min) (point-max) pathname)
309 )
310 (kill-buffer manifest-buf)
311 )
312 (progn
313 ;; We can't determine the package name from an extracted
314 ;; file in the tar output buffer.
315 ))
316 ))
317 )
318 ;; Restore old case-fold-search status
319 (setq case-fold-search old-case-fold-search))
320 ))
321
322 ;;;###autoload 60 ;;;###autoload
323 (defun package-admin-add-binary-package (file &optional pkg-dir) 61 (defun package-admin-add-binary-package (file &optional pkg-dir)
324 "Install a pre-bytecompiled XEmacs package into package hierarchy." 62 "Install a pre-bytecompiled XEmacs package into package hierarchy."
325 (interactive "fPackage tarball: ") 63 (interactive "fPackage tarball: ")
326 (let ((buf (get-buffer-create package-admin-temp-buffer)) 64 (when (null pkg-dir)
327 (status 1) 65 (when (or (not (listp late-packages))
328 start err-list 66 (not late-packages))
329 ) 67 (error "No package path"))
330 (setq pkg-dir (package-admin-get-install-dir 'unknown pkg-dir)) 68 (setq pkg-dir (car (last late-packages))))
331 ;; Ensure that the current directory doesn't change
332 (save-excursion
333 (set-buffer buf)
334 ;; This is not really needed
335 (setq default-directory (file-name-as-directory pkg-dir))
336 (setq case-fold-search t)
337 (buffer-disable-undo)
338 (goto-char (setq start (point-max)))
339 (if (= 0 (setq status (funcall package-admin-install-function
340 file pkg-dir buf)))
341 (progn
342 ;; First, check for errors.
343 ;; We can't necessarily rely upon process error codes.
344 (catch 'done
345 (goto-char start)
346 (setq err-list package-admin-error-messages)
347 (while err-list
348 (if (re-search-forward (car err-list) nil t)
349 (progn
350 (setq status 1)
351 (throw 'done nil)
352 ))
353 (setq err-list (cdr err-list))
354 )
355 )
356 ;; Make sure that the MANIFEST file exists
357 (package-admin-check-manifest buf pkg-dir)
358 ))
359 )
360 status
361 ))
362 69
363 (defun package-admin-rmtree (directory) 70 (let ((buf (get-buffer-create package-admin-temp-buffer)))
364 "Delete a directory and all of its contents, recursively. 71 (call-process "add-big-package.sh"
365 This is a feeble attempt at making a portable rmdir." 72 nil
366 (setq directory (file-name-as-directory directory)) 73 buf
367 (let ((files (directory-files directory nil nil nil t)) 74 t
368 (dirs (directory-files directory nil nil nil 'dirs))) 75 ;; rest of command line follows
369 (while dirs 76 package-admin-xemacs file pkg-dir)))
370 (if (not (member (car dirs) '("." "..")))
371 (let ((dir (expand-file-name (car dirs) directory)))
372 (condition-case err
373 (if (file-symlink-p dir) ;; just in case, handle symlinks
374 (delete-file dir)
375 (package-admin-rmtree dir))
376 (file-error
377 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err)))))
378 (setq dirs (cdr dirs))))
379 (while files
380 (condition-case err
381 (delete-file (expand-file-name (car files) directory))
382 (file-error
383 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))
384 (setq files (cdr files)))
385 (condition-case err
386 (delete-directory directory)
387 (file-error
388 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))))
389
390 (defun package-admin-get-lispdir (pkg-topdir package)
391 (let (package-lispdir)
392 (if (and (setq package-lispdir (expand-file-name "lisp" pkg-topdir))
393 (setq package-lispdir (expand-file-name (symbol-name package)
394 package-lispdir))
395 (file-accessible-directory-p package-lispdir))
396 package-lispdir)
397 ))
398
399 (defun package-admin-delete-binary-package (package pkg-topdir)
400 "Delete a binary installation of PACKAGE below directory PKG-TOPDIR.
401 PACKAGE is a symbol, not a string."
402 (let ( (tmpbuf " *pkg-manifest*") manifest-file package-lispdir dirs file)
403 (setq pkg-topdir (package-admin-get-install-dir package pkg-topdir))
404 (setq manifest-file (package-admin-get-manifest-file pkg-topdir package))
405 (if (file-exists-p manifest-file)
406 (progn
407 ;; The manifest file exists! Use it to delete the old distribution.
408 (message "Removing old files for package \"%s\" ..." package)
409 (sit-for 0)
410 (setq tmpbuf (get-buffer-create tmpbuf))
411 (with-current-buffer tmpbuf
412 (buffer-disable-undo)
413 (erase-buffer)
414 (insert-file-contents manifest-file)
415 (goto-char (point-min))
416
417 ;; For each entry in the MANIFEST ...
418 (while (< (point) (point-max))
419 (beginning-of-line)
420 (setq file (expand-file-name (buffer-substring
421 (point)
422 (point-at-eol))
423 pkg-topdir))
424 (if (file-directory-p file)
425 ;; Keep a record of each directory
426 (setq dirs (cons file dirs))
427 ;; Delete each file.
428 ;; Make sure that the file is writable.
429 ;; (This is important under MS Windows.)
430 ;; I do not know why it important under MS Windows but
431 ;; 1. It bombs out out when the file does not exist. This can be condition-cased
432 ;; 2. If I removed the write permissions, I do not want XEmacs to just ignore them.
433 ;; If it wants to, XEmacs may ask, but that is about all
434 ;; (set-file-modes file 438) ;; 438 -> #o666
435 ;; Note, user might have removed the file!
436 (condition-case ()
437 (delete-file file)
438 (error nil))) ;; We may want to turn the error into a Warning?
439 (forward-line 1))
440
441 ;; Delete empty directories.
442 (if dirs
443 (let ( (orig-default-directory default-directory)
444 directory files file )
445 ;; Make sure we preserve the existing `default-directory'.
446 ;; JV, why does this change the default directory? Does it indeed?
447 (unwind-protect
448 (progn
449 ;; Warning: destructive sort!
450 (setq dirs (nreverse (sort dirs 'string<)))
451 ; ;; For each directory ...
452 ; (while dirs
453 ; (setq directory (file-name-as-directory (car dirs)))
454 ; (setq files (directory-files directory))
455 ; ;; Delete the directory if it's empty.
456 ; (if (catch 'done
457 ; (while files
458 ; (setq file (car files))
459 ; (if (and (not (string= file "."))
460 ; (not (string= file "..")))
461 ; (throw 'done nil))
462 ; (setq files (cdr files))
463 ; )
464 ; t)
465 ; (
466 ; (delete-directory directory))
467 ; (setq dirs (cdr dirs))
468 ; )
469 ;; JV, On all OS's that I know of delete-directory fails on
470 ;; on non-empty dirs anyway
471 (mapc
472 (lambda (dir)
473 (condition-case ()
474 (delete-directory dir)))
475 dirs))
476 (setq default-directory orig-default-directory)
477 )))
478 )
479 (kill-buffer tmpbuf)
480 ;; Delete the MANIFEST file
481 ;; (set-file-modes manifest-file 438) ;; 438 -> #o666
482 ;; Note. Packages can have MANIFEST in MANIFEST.
483 (condition-case ()
484 (delete-file manifest-file)
485 (error nil)) ;; Do warning?
486 (message "Removing old files for package \"%s\" ... done" package))
487 ;; The manifest file doesn't exist. Fallback to just deleting the
488 ;; package-specific lisp directory, if it exists.
489 ;;
490 ;; Delete old lisp directory, if any
491 ;; Gads, this is ugly. However, we're not supposed to use `concat'
492 ;; in the name of portability.
493 (when (setq package-lispdir (package-admin-get-lispdir pkg-topdir
494 package))
495 (message "Removing old lisp directory \"%s\" ..."
496 package-lispdir)
497 (sit-for 0)
498 (package-admin-rmtree package-lispdir)
499 (message "Removing old lisp directory \"%s\" ... done"
500 package-lispdir)
501 ))
502 ;; Delete the package from the database of installed packages.
503 (package-delete-name package)))
504 77
505 (provide 'package-admin) 78 (provide 'package-admin)
506 79
507 ;;; package-admin.el ends here 80 ;;; package-admin.el ends here