Mercurial > hg > xemacs-beta

comparison lisp/package-admin.el @ 373:6240c7796c7a r21-2b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2b2
author cvs
date Mon, 13 Aug 2007 11:04:06 +0200
parents cc15677e0335
children a300bb07d72d
comparison
equal deleted inserted replaced
372:49e1ed2d7ed8 373:6240c7796c7a
35 (defvar package-admin-xemacs (concat invocation-directory invocation-name) 35 (defvar package-admin-xemacs (concat invocation-directory invocation-name)
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
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.")
40 104
41 ;;;###autoload 105 ;;;###autoload
42 (defun package-admin-add-single-file-package (file destdir &optional pkg-dir) 106 (defun package-admin-add-single-file-package (file destdir &optional pkg-dir)
43 "Install a single file Lisp package into XEmacs package hierarchy. 107 "Install a single file Lisp package into XEmacs package hierarchy.
44 `file' should be the full path to the lisp file to install. 108 `file' should be the full path to the lisp file to install.
55 buf 119 buf
56 t 120 t
57 ;; rest of command line follows 121 ;; rest of command line follows
58 package-admin-xemacs file destination))) 122 package-admin-xemacs file destination)))
59 123
60 ;;;###autoload 124 (defun package-admin-install-function-mswindows (file pkg-dir buf)
61 (defun package-admin-add-binary-package (file &optional pkg-dir) 125 "Install function for mswindows"
62 "Install a pre-bytecompiled XEmacs package into package hierarchy." 126 (let ( (default-directory pkg-dir) )
63 (interactive "fPackage tarball: ") 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)
64 (when (null pkg-dir) 150 (when (null pkg-dir)
65 (when (or (not (listp late-packages)) 151 (when (or (not (listp late-packages))
66 (not late-packages)) 152 (not late-packages))
67 (error "No package path")) 153 (error "No package path"))
68 (setq pkg-dir (car (last late-packages)))) 154 (setq pkg-dir (car (last late-packages))))
69 155 pkg-dir
70 (let ((buf (get-buffer-create package-admin-temp-buffer))) 156 )
71 (call-process "add-big-package.sh" 157
72 nil 158 (defun package-admin-get-manifest-file (pkg-topdir package)
73 buf 159 "Return the name of the MANIFEST file for package PACKAGE.
74 t 160 Note that PACKAGE is a symbol, and not a string."
75 ;; rest of command line follows 161 (let (dir)
76 package-admin-xemacs file pkg-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 ))
77 474
78 (provide 'package-admin) 475 (provide 'package-admin)
79 476
80 ;;; package-admin.el ends here 477 ;;; package-admin.el ends here