Mercurial > hg > xemacs-beta

comparison lisp/package-admin.el @ 321:19dcec799385 r21-0-58

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0-58
author cvs
date Mon, 13 Aug 2007 10:46:44 +0200
parents afd57c14dfc8
children f2b5d7006b0a
comparison
equal deleted inserted replaced
320:73c75c43c1f2 321:19dcec799385
144 ; buf 144 ; buf
145 ; t 145 ; t
146 ; ;; rest of command line follows 146 ; ;; rest of command line follows
147 ; package-admin-xemacs file pkg-dir)) 147 ; package-admin-xemacs file pkg-dir))
148 148
149 (defun package-admin-get-install-dir (pkg-dir) 149 (defun package-admin-get-install-dir (package pkg-dir &optional mule-related)
150 (when (null pkg-dir) 150 "If PKG-DIR is non-nil return that,
151 (when (or (not (listp late-packages)) 151 else return the current location of the package if it is already installed
152 (not late-packages)) 152 or return a location appropriate for the package otherwise."
153 (error "No package path")) 153 (if pkg-dir
154 (setq pkg-dir (car (last late-packages)))) 154 pkg-dir
155 pkg-dir 155 (let ((package-feature (intern-soft (concat
156 ) 156 (symbol-name package) "-autoloads")))
157 autoload-dir)
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
164 (setq pkg-dir
165 (car-safe (member-if (lambda (h)
166 (string-match (concat "^" (regexp-quote h))
167 autoload-dir))
168 late-packages))))
169 (if pkg-dir
170 pkg-dir
171 ;; Ok we need to guess
172 (if mule-related
173 (package-admin-get-install-dir 'mule-base nil nil)
174 (car (last late-packages)))))))
175
176
157 177
158 (defun package-admin-get-manifest-file (pkg-topdir package) 178 (defun package-admin-get-manifest-file (pkg-topdir package)
159 "Return the name of the MANIFEST file for package PACKAGE. 179 "Return the name of the MANIFEST file for package PACKAGE.
160 Note that PACKAGE is a symbol, and not a string." 180 Note that PACKAGE is a symbol, and not a string."
161 (let (dir) 181 (let (dir)
297 (interactive "fPackage tarball: ") 317 (interactive "fPackage tarball: ")
298 (let ((buf (get-buffer-create package-admin-temp-buffer)) 318 (let ((buf (get-buffer-create package-admin-temp-buffer))
299 (status 1) 319 (status 1)
300 start err-list 320 start err-list
301 ) 321 )
302 (setq pkg-dir (package-admin-get-install-dir pkg-dir)) 322 (setq pkg-dir (package-admin-get-install-dir 'unknown pkg-dir))
303 ;; Insure that the current directory doesn't change 323 ;; Insure that the current directory doesn't change
304 (save-excursion 324 (save-excursion
305 (set-buffer buf) 325 (set-buffer buf)
306 (setq default-directory pkg-dir) 326 (setq default-directory pkg-dir)
307 (setq case-fold-search t) 327 (setq case-fold-search t)
332 )) 352 ))
333 353
334 (defun package-admin-rmtree (directory) 354 (defun package-admin-rmtree (directory)
335 "Delete a directory and all of its contents, recursively. 355 "Delete a directory and all of its contents, recursively.
336 This is a feeble attempt at making a portable rmdir." 356 This is a feeble attempt at making a portable rmdir."
337 (let ( (orig-default-directory default-directory) files dirs dir) 357 (setq directory (file-name-as-directory directory))
338 (unwind-protect 358 (let ((files (directory-files directory nil nil nil t))
339 (progn 359 (dirs (directory-files directory nil nil nil 'dirs)))
340 (setq directory (file-name-as-directory directory)) 360 (while dirs
341 (setq files (directory-files directory nil nil nil t)) 361 (if (not (member (car dirs) '("." "..")))
342 (setq dirs (directory-files directory nil nil nil 'dirs)) 362 (let ((dir (expand-file-name (car dirs) directory)))
343 (while dirs 363 (condition-case err
344 (setq dir (car dirs)) 364 (if (file-symlink-p dir) ;; just in case, handle symlinks
345 (if (file-symlink-p dir) ;; just in case, handle symlinks 365 (delete-file dir)
346 (delete-file dir) 366 (package-admin-rmtree dir))
347 (if (not (or (string-equal dir ".") (string-equal dir ".."))) 367 (file-error
348 (package-admin-rmtree (expand-file-name dir directory)))) 368 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err)))))
349 (setq dirs (cdr dirs)) 369 (setq dirs (cdr dirs))))
350 ) 370 (while files
351 (setq default-directory directory) 371 (condition-case err
352 (condition-case err 372 (delete-file (expand-file-name (car files) directory))
353 (progn 373 (file-error
354 (while files 374 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))
355 (delete-file (car files)) 375 (setq files (cdr files)))
356 (setq files (cdr files)) 376 (condition-case err
357 ) 377 (delete-directory directory)
358 (delete-directory directory) 378 (file-error
359 ) 379 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))))
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 380
369 (defun package-admin-get-lispdir (pkg-topdir package) 381 (defun package-admin-get-lispdir (pkg-topdir package)
370 (let (package-lispdir) 382 (let (package-lispdir)
371 (if (and (setq package-lispdir (expand-file-name "lisp" pkg-topdir)) 383 (if (and (setq package-lispdir (expand-file-name "lisp" pkg-topdir))
372 (setq package-lispdir (expand-file-name (symbol-name package) 384 (setq package-lispdir (expand-file-name (symbol-name package)
377 389
378 (defun package-admin-delete-binary-package (package pkg-topdir) 390 (defun package-admin-delete-binary-package (package pkg-topdir)
379 "Delete a binary installation of PACKAGE below directory PKG-TOPDIR. 391 "Delete a binary installation of PACKAGE below directory PKG-TOPDIR.
380 PACKAGE is a symbol, not a string." 392 PACKAGE is a symbol, not a string."
381 (let ( (tmpbuf " *pkg-manifest*") manifest-file package-lispdir dirs file) 393 (let ( (tmpbuf " *pkg-manifest*") manifest-file package-lispdir dirs file)
382 (if (not pkg-topdir) 394 (setq pkg-topdir (package-admin-get-install-dir package pkg-topdir))
383 (setq pkg-topdir (package-admin-get-install-dir nil)))
384 (setq manifest-file (package-admin-get-manifest-file pkg-topdir package)) 395 (setq manifest-file (package-admin-get-manifest-file pkg-topdir package))
385 (if (file-exists-p manifest-file) 396 (if (file-exists-p manifest-file)
386 (progn 397 (progn
387 ;; The manifest file exists! Use it to delete the old distribution. 398 ;; The manifest file exists! Use it to delete the old distribution.
388 (message "Removing old files for package \"%s\" ..." package) 399 (message "Removing old files for package \"%s\" ..." package)
389 (sit-for 0) 400 (sit-for 0)
390 (setq tmpbuf (get-buffer-create tmpbuf)) 401 (setq tmpbuf (get-buffer-create tmpbuf))
391 (save-excursion 402 (with-current-buffer tmpbuf
392 (set-buffer tmpbuf) 403 (buffer-disable-undo)
393 (buffer-disable-undo tmpbuf) 404 (erase-buffer)
394 (erase-buffer tmpbuf)
395 (insert-file-contents manifest-file) 405 (insert-file-contents manifest-file)
396 (goto-char (point-min)) 406 (goto-char (point-min))
407
397 ;; For each entry in the MANIFEST ... 408 ;; For each entry in the MANIFEST ...
398 (while (< (point) (point-max)) 409 (while (< (point) (point-max))
399 (beginning-of-line) 410 (beginning-of-line)
400 (setq file (expand-file-name (buffer-substring 411 (setq file (expand-file-name (buffer-substring
401 (point) 412 (point)
402 (save-excursion (end-of-line) 413 (point-at-eol))
403 (point)))
404 pkg-topdir)) 414 pkg-topdir))
405 (if (file-directory-p file) 415 (if (file-directory-p file)
406 ;; Keep a record of each directory 416 ;; Keep a record of each directory
407 (setq dirs (cons file dirs)) 417 (setq dirs (cons file dirs))
408 (progn
409 ;; Delete each file. 418 ;; Delete each file.
410 ;; Make sure that the file is writable. 419 ;; Make sure that the file is writable.
411 ;; (This is important under MS Windows.) 420 ;; (This is important under MS Windows.)
412 (set-file-modes file 438) ;; 438 -> #o666 421 ;; I do not know why it important under MS Windows but
413 (delete-file file) 422 ;; 1. It bombs out out when the file does not exist. This can be condition-cased
414 )) 423 ;; 2. If I removed the write permissions, I do not want XEmacs to just ignore them.
415 (forward-line 1) 424 ;; If it wants to, XEmacs may ask, but that is about all
416 ) 425 ;; (set-file-modes file 438) ;; 438 -> #o666
426 ;; Note, user might have removed the file!
427 (condition-case ()
428 (delete-file file)
429 (error nil))) ;; We may want to turn the error into a Warning?
430 (forward-line 1))
431
417 ;; Delete empty directories. 432 ;; Delete empty directories.
418 (if dirs 433 (if dirs
419 (let ( (orig-default-directory default-directory) 434 (let ( (orig-default-directory default-directory)
420 directory files file ) 435 directory files file )
421 ;; Make sure we preserve the existing `default-directory'. 436 ;; Make sure we preserve the existing `default-directory'.
437 ;; JV, why does this change the default directory? Does it indeed?
422 (unwind-protect 438 (unwind-protect
423 (progn 439 (progn
424 ;; Warning: destructive sort! 440 ;; Warning: destructive sort!
425 (setq dirs (nreverse (sort dirs 'string<))) 441 (setq dirs (nreverse (sort dirs 'string<)))
426 ;; For each directory ... 442 ; ;; For each directory ...
427 (while dirs 443 ; (while dirs
428 (setq directory (file-name-as-directory (car dirs))) 444 ; (setq directory (file-name-as-directory (car dirs)))
429 (setq files (directory-files directory)) 445 ; (setq files (directory-files directory))
430 ;; Delete the directory if it's empty. 446 ; ;; Delete the directory if it's empty.
431 (if (catch 'done 447 ; (if (catch 'done
432 (while files 448 ; (while files
433 (setq file (car files)) 449 ; (setq file (car files))
434 (if (and (not (string= file ".")) 450 ; (if (and (not (string= file "."))
435 (not (string= file ".."))) 451 ; (not (string= file "..")))
436 (throw 'done nil)) 452 ; (throw 'done nil))
437 (setq files (cdr files)) 453 ; (setq files (cdr files))
438 ) 454 ; )
439 t) 455 ; t)
440 (delete-directory directory)) 456 ; (
441 (setq dirs (cdr dirs)) 457 ; (delete-directory directory))
442 ) 458 ; (setq dirs (cdr dirs))
443 ) 459 ; )
460 ;; JV, On all OS's that I know of delete-directory fails on
461 ;; on non-empty dirs anyway
462 (mapc
463 (lambda (dir)
464 (condition-case ()
465 (delete-directory dir)))
466 dirs))
444 (setq default-directory orig-default-directory) 467 (setq default-directory orig-default-directory)
445 ))) 468 )))
446 ) 469 )
447 (kill-buffer tmpbuf) 470 (kill-buffer tmpbuf)
448 ;; Delete the MANIFEST file 471 ;; Delete the MANIFEST file
449 (set-file-modes manifest-file 438) ;; 438 -> #o666 472 ;; (set-file-modes manifest-file 438) ;; 438 -> #o666
450 (delete-file manifest-file) 473 ;; Note. Packages can have MANIFEST in MANIFEST.
451 (message "Removing old files for package \"%s\" ... done" package) 474 (condition-case ()
452 ) 475 (delete-file manifest-file)
453 (progn 476 (error nil)) ;; Do warning?
477 (message "Removing old files for package \"%s\" ... done" package))
454 ;; The manifest file doesn't exist. Fallback to just deleting the 478 ;; The manifest file doesn't exist. Fallback to just deleting the
455 ;; package-specific lisp directory, if it exists. 479 ;; package-specific lisp directory, if it exists.
456 ;; 480 ;;
457 ;; Delete old lisp directory, if any 481 ;; Delete old lisp directory, if any
458 ;; Gads, this is ugly. However, we're not supposed to use `concat' 482 ;; Gads, this is ugly. However, we're not supposed to use `concat'
459 ;; in the name of portability. 483 ;; in the name of portability.
460 (if (setq package-lispdir (package-admin-get-lispdir pkg-topdir 484 (when (setq package-lispdir (package-admin-get-lispdir pkg-topdir
461 package)) 485 package))
462 (progn
463 (message "Removing old lisp directory \"%s\" ..." 486 (message "Removing old lisp directory \"%s\" ..."
464 package-lispdir) 487 package-lispdir)
465 (sit-for 0) 488 (sit-for 0)
466 (package-admin-rmtree package-lispdir) 489 (package-admin-rmtree package-lispdir)
467 (message "Removing old lisp directory \"%s\" ... done" 490 (message "Removing old lisp directory \"%s\" ... done"
468 package-lispdir) 491 package-lispdir)
469 )) 492 ))
470 ))
471 ;; Delete the package from the database of installed packages. 493 ;; Delete the package from the database of installed packages.
472 (package-delete-name package) 494 (package-delete-name package)))
473 ))
474 495
475 (provide 'package-admin) 496 (provide 'package-admin)
476 497
477 ;;; package-admin.el ends here 498 ;;; package-admin.el ends here