Mercurial > hg > xemacs-beta

comparison lisp/package-get.el @ 318:afd57c14dfc8 r21-0b57

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b57
author cvs
date Mon, 13 Aug 2007 10:45:36 +0200
parents 512e409c26a2
children 19dcec799385
comparison
equal deleted inserted replaced
317:a2fc9afbef65 318:afd57c14dfc8
147 147
148 (defvar package-get-dir (temp-directory) 148 (defvar package-get-dir (temp-directory)
149 "*Where to store temporary files for staging.") 149 "*Where to store temporary files for staging.")
150 150
151 (defvar package-get-remote 151 (defvar package-get-remote
152 '( 152 '(("ftp.xemacs.org" "/pub/xemacs/packages"))
153 ("ftp.xemacs.org" "/pub/xemacs/beta/xemacs-21.0/packages/binary-packages")
154 ("ftp.xemacs.org" "/pub/xemacs/beta/xemacs-21.0/packages/single-file-packages")
155 ("ftp.xemacs.org" "/pub/xemacs/package"))
156 "*List of remote sites to contact for downloading packages. 153 "*List of remote sites to contact for downloading packages.
157 List format is '(site-name directory-on-site). Each site is tried in 154 List format is '(site-name directory-on-site). Each site is tried in
158 order until the package is found. As a special case, `site-name' can be 155 order until the package is found. As a special case, `site-name' can be
159 `nil', in which case `directory-on-site' is treated as a local directory.") 156 `nil', in which case `directory-on-site' is treated as a local directory.")
160 157
161 (defvar package-get-remove-copy nil 158 (defvar package-get-remove-copy nil
162 "*After copying and installing a package, if this is T, then remove the 159 "*After copying and installing a package, if this is T, then remove the
163 copy. Otherwise, keep it around.") 160 copy. Otherwise, keep it around.")
164
165 (defun package-get-rmtree (directory)
166 "Delete a directory and all of its contents, recursively.
167 This is a feeble attempt at making a portable rmdir."
168 (let ( (orig-default-directory default-directory) files dirs dir)
169 (unwind-protect
170 (progn
171 (setq directory (file-name-as-directory directory))
172 (setq files (directory-files directory nil nil nil t))
173 (setq dirs (directory-files directory nil nil nil 'dirs))
174 (while dirs
175 (setq dir (car dirs))
176 (if (file-symlink-p dir) ;; just in case, handle symlinks
177 (delete-file dir)
178 (if (not (or (string-equal dir ".") (string-equal dir "..")))
179 (package-get-rmtree (expand-file-name dir directory))))
180 (setq dirs (cdr dirs))
181 )
182 (setq default-directory directory)
183 (condition-case err
184 (progn
185 (while files
186 (delete-file (car files))
187 (setq files (cdr files))
188 )
189 (delete-directory directory)
190 )
191 (file-error
192 (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err)))
193 )
194 )
195 (progn
196 (setq default-directory orig-default-directory)
197 ))
198 ))
199
200 ;;;###autoload
201 (defun package-get-update-all ()
202 "Fetch and install the latest versions of all currently installed packages."
203 (interactive)
204 ;; Load a fresh copy
205 (catch 'exit
206 (mapcar (lambda (pkg)
207 (if (not (package-get (car pkg) nil 'never))
208 (throw 'exit nil) ;; Bail out if error detected
209 ))
210 packages-package-list)))
211 161
212 (defun package-get-interactive-package-query (get-version package-symbol) 162 (defun package-get-interactive-package-query (get-version package-symbol)
213 "Perform interactive querying for package and optional version. 163 "Perform interactive querying for package and optional version.
214 Query for a version if GET-VERSION is non-nil. Return package name as 164 Query for a version if GET-VERSION is non-nil. Return package name as
215 a symbol instead of a string if PACKAGE-SYMBOL is non-nil. 165 a symbol instead of a string if PACKAGE-SYMBOL is non-nil.
241 ) 191 )
242 (if package-symbol 192 (if package-symbol
243 (list package-symbol) 193 (list package-symbol)
244 (list package))) 194 (list package)))
245 ))) 195 )))
196
197 ;;;###autoload
198 (defun package-get-delete-package (package &optional pkg-topdir)
199 "Delete an installation of PACKAGE below directory PKG-TOPDIR.
200 PACKAGE is a symbol, not a string.
201 This is just an interactive wrapper for `package-admin-delete-binary-package'."
202 (interactive (package-get-interactive-package-query nil t))
203 (package-admin-delete-binary-package package pkg-topdir))
204
205 ;;;###autoload
206 (defun package-get-update-all ()
207 "Fetch and install the latest versions of all currently installed packages."
208 (interactive)
209 ;; Load a fresh copy
210 (catch 'exit
211 (mapcar (lambda (pkg)
212 (if (not (package-get (car pkg) nil 'never))
213 (throw 'exit nil) ;; Bail out if error detected
214 ))
215 packages-package-list)))
246 216
247 ;;;###autoload 217 ;;;###autoload
248 (defun package-get-all (package version &optional fetched-packages) 218 (defun package-get-all (package version &optional fetched-packages)
249 "Fetch PACKAGE with VERSION and all other required packages. 219 "Fetch PACKAGE with VERSION and all other required packages.
250 Uses `package-get-base' to determine just what is required and what 220 Uses `package-get-base' to determine just what is required and what
364 package) version)) 334 package) version))
365 (found nil) 335 (found nil)
366 (search-dirs package-get-remote) 336 (search-dirs package-get-remote)
367 (base-filename (package-get-info-prop this-package 'filename)) 337 (base-filename (package-get-info-prop this-package 'filename))
368 (package-status t) 338 (package-status t)
369 filenames full-package-filename package-lispdir) 339 filenames full-package-filename)
370 (if (null this-package) 340 (if (null this-package)
371 (error "Couldn't find package %s with version %s" 341 (error "Couldn't find package %s with version %s"
372 package version)) 342 package version))
373 (if (null base-filename) 343 (if (null base-filename)
374 (error "No filename associated with package %s, version %s" 344 (error "No filename associated with package %s, version %s"
464 (if (not (string= (md5 (current-buffer)) 434 (if (not (string= (md5 (current-buffer))
465 (package-get-info-prop this-package 435 (package-get-info-prop this-package
466 'md5sum))) 436 'md5sum)))
467 (error "Package %s does not match md5 checksum" base-filename))) 437 (error "Package %s does not match md5 checksum" base-filename)))
468 438
469 ;; Now delete old lisp directory, if any 439 (package-admin-delete-binary-package package install-dir)
470 ;;
471 ;; Gads, this is ugly. However, we're not supposed to use `concat'
472 ;; in the name of portability.
473 (if (and (setq package-lispdir (expand-file-name "lisp" install-dir))
474 (setq package-lispdir (expand-file-name (symbol-name package)
475 package-lispdir))
476 (file-accessible-directory-p package-lispdir))
477 (progn
478 (message "Removing old lisp directory \"%s\" ..." package-lispdir)
479 (sit-for 0)
480 (package-get-rmtree package-lispdir)
481 ))
482 440
483 (message "Installing package `%s' ..." package) (sit-for 0) 441 (message "Installing package `%s' ..." package) (sit-for 0)
484 (let ((status 442 (let ((status
485 (package-admin-add-binary-package full-package-filename 443 (package-admin-add-binary-package full-package-filename
486 install-dir))) 444 install-dir)))
487 (if (= status 0) 445 (if (= status 0)
488 (progn 446 (progn
489 ;; clear messages so that only messages from 447 ;; clear messages so that only messages from
490 ;; package-get-init-package are seen, below. 448 ;; package-get-init-package are seen, below.
491 (clear-message) 449 (clear-message)
492 (if (package-get-init-package package-lispdir) 450 (if (package-get-init-package (package-admin-get-lispdir
451 install-dir package))
493 (progn 452 (progn
494 (message "Added package `%s'" package) 453 (message "Added package `%s'" package)
495 (sit-for 0) 454 (sit-for 0)
496 ) 455 )
497 (progn 456 (progn
579 Creates `package-get-dir' it it doesn't exist." 538 Creates `package-get-dir' it it doesn't exist."
580 (interactive "FPackage filename: ") 539 (interactive "FPackage filename: ")
581 (if (not (file-exists-p package-get-dir)) 540 (if (not (file-exists-p package-get-dir))
582 (make-directory package-get-dir)) 541 (make-directory package-get-dir))
583 (expand-file-name 542 (expand-file-name
584 (file-name-nondirectory (or (nth 2 (efs-ftp-path filename)) filename)) 543 (file-name-nondirectory (or (and (fboundp 'efs-ftp-path)
544 (nth 2 (efs-ftp-path filename)))
545 filename))
585 (file-name-as-directory package-get-dir))) 546 (file-name-as-directory package-get-dir)))
586
587 547
588 (defun package-get-remote-filename (search filename) 548 (defun package-get-remote-filename (search filename)
589 "Return FILENAME as a remote filename. 549 "Return FILENAME as a remote filename.
590 It first checks if FILENAME already is a remote filename. If it is 550 It first checks if FILENAME already is a remote filename. If it is
591 not, then it uses the (car search) as the remote site-name and the (cadr 551 not, then it uses the (car search) as the remote site-name and the (cadr