Mercurial > hg > xemacs-beta

comparison lisp/package-admin.el @ 1365:02909207294a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2003-03-20 13:19:56 by youngs] 2003-03-20 Steve Youngs <youngs@xemacs.org> * menubar-items.el (default-menubar): Add a "Pre-Release Download Sites" submenu to "Tools -> Packages" menu. Filter the package download sites menus through `menu-split-long-menu'. * obsolete.el (pui-add-install-directory): New. (package-get-download-menu): New. * package-admin.el: (package-admin-add-single-file-package): Removed. (package-admin-get-install-dir): Don't rely on an installed xemacs-base package to guess where a package needs to be installed to. (package-admin-get-manifest-file): Whitespace clean up. (package-admin-check-manifest): Use `directory-sep-char' to compute regexp. Only search 'lisp' and 'man' directories to determine package name. Don't error is xemacs-base package isn't installed, just don't sort the MANIFEST file and issue a warning. (package-admin-add-binary-package): Whitespace clean up. (package-admin-get-lispdir): Ditto. (package-admin-delete-binary-package): Use `with-temp-buffer' instead of creating a temporary buffer manually. * package-get.el: (package-get-remote): Change custom type so that only either a single directory or remote host:directory can be selected. (package-get-download-sites): Put the sites into alphabetical order of country. Make the description element be "Country (site)" instead of the other way around. (package-get-pre-release-download-sites): New. (package-get-require-signed-base-updates): Default to t. (package-get-download-menu): Removed. (package-get-locate-file): Change to reflect new format of 'package-get-remote'. (package-get-update-base-from-buffer): Whitespace clean up and remove an unneccessary 'when'. (package-get-interactive-package-query): Whitespace clean up. (package-get-update-all): Ditto. (package-get-all): Ditto. (package-get-init-package): Ditto. (package-get-info): New. (package-get): Bring into line with new format of 'package-get-remote'. Error if non-Mule XEmacsen try to install Mule packages. Don't rely on a Mule package having 'mule-base' in its "REQUIRES" to determine if it is a Mule package or not, instead we test "CATEGORY". Better handling of the situation where a partial package tarball exists on the local hard drive from a previous interupted download. Clean up after a failed package install. (package-get-set-version-prop): Removed. (package-get-installedp): Whitespace clean up. * package-ui.el: Whitespace clean up. (pui-info-buffer): Make it a defcustom. (pui-directory-exists): Removed. (pui-package-dir-list): Removed. (pui-add-install-directory): Removed. (package-ui-download-menu): New. (package-ui-pre-release-download-menu): New. (pui-set-local-package-get-directory): New. (pui-package-symbol-char): Whitespace clean up. (pui-update-package-display): Ditto. (pui-toggle-package): Ditto. (pui-toggle-package-key): Ditto. (pui-toggle-package-delete): Ditto. (pui-toggle-package-delete-key): Ditto. (pui-toggle-package-event): Ditto. (pui-toggle-verbosity-redisplay): Ditto. (pui-install-selected-packages): Ditto. (pui-help-echo): Ditto. (pui-display-info): Ditto. (pui-list-packages): Ditto. * packages.el: Whitespace clean up.
author youngs
date Thu, 20 Mar 2003 13:19:59 +0000
parents 79940b592197
children 69a674f5861f
comparison
equal deleted inserted replaced
1364:29e39e3ac319 1365:02909207294a
112 (defvar package-delete-hook nil 112 (defvar package-delete-hook nil
113 "*List of hook functions to be called when a package is deleted. The 113 "*List of hook functions to be called when a package is deleted. The
114 hook is called *before* the package is deleted. The hook function is passed 114 hook is called *before* the package is deleted. The hook function is passed
115 two arguments: the package name, and the install directory.") 115 two arguments: the package name, and the install directory.")
116 116
117 ;;;###autoload
118 (defun package-admin-add-single-file-package (file destdir &optional pkg-dir)
119 "Install a single file Lisp package into XEmacs package hierarchy.
120 `file' should be the full path to the lisp file to install.
121 `destdir' should be a simple directory name.
122 The optional `pkg-dir' can be used to override the default package hierarchy
123 \(car \(last late-packages))."
124 (interactive "fLisp File: \nsDestination: ")
125 (when (null pkg-dir)
126 (setq pkg-dir (car (last late-packages))))
127 (let ((destination (concat pkg-dir "/lisp/" destdir))
128 (buf (get-buffer-create package-admin-temp-buffer)))
129 (call-process "add-little-package.sh"
130 nil
131 buf
132 t
133 ;; rest of command line follows
134 package-admin-xemacs file destination)))
135
136 (defun package-admin-install-function-mswindows (file pkg-dir buffer) 117 (defun package-admin-install-function-mswindows (file pkg-dir buffer)
137 "Install function for mswindows." 118 "Install function for mswindows."
138 (let ((default-directory (file-name-as-directory pkg-dir))) 119 (let ((default-directory (file-name-as-directory pkg-dir)))
139 (unless (file-directory-p default-directory) 120 (unless (file-directory-p default-directory)
140 (make-directory default-directory t)) 121 (make-directory default-directory t))
150 (unless (file-directory-p pkg-dir) 131 (unless (file-directory-p pkg-dir)
151 (make-directory pkg-dir t)) 132 (make-directory pkg-dir t))
152 ;; Don't assume GNU tar. 133 ;; Don't assume GNU tar.
153 (if (shell-command (concat "gunzip -c " filename " | tar xvf -") buffer) 134 (if (shell-command (concat "gunzip -c " filename " | tar xvf -") buffer)
154 0 135 0
155 1) 136 1)))
156 ))
157
158 ; (call-process "add-big-package.sh"
159 ; nil
160 ; buffer
161 ; t
162 ; ;; rest of command line follows
163 ; package-admin-xemacs file pkg-dir))
164 137
165 (defun package-admin-get-install-dir (package pkg-dir &optional mule-related) 138 (defun package-admin-get-install-dir (package pkg-dir &optional mule-related)
166 "If PKG-DIR is non-nil return that, 139 "If PKG-DIR is non-nil return that,
167 else return the current location of the package if it is already installed 140 else return the current location of the package if it is already installed
168 or return a location appropriate for the package otherwise." 141 or return a location appropriate for the package otherwise."
185 (if pkg-dir 158 (if pkg-dir
186 pkg-dir 159 pkg-dir
187 ;; Ok we need to guess 160 ;; Ok we need to guess
188 (if mule-related 161 (if mule-related
189 (package-admin-get-install-dir 'mule-base nil nil) 162 (package-admin-get-install-dir 'mule-base nil nil)
190 (if (eq package 'xemacs-base) 163 (car (last late-packages)))))))
191 (car (last late-packages))
192 (package-admin-get-install-dir 'xemacs-base nil nil)))))))
193
194
195 164
196 (defun package-admin-get-manifest-file (pkg-topdir package) 165 (defun package-admin-get-manifest-file (pkg-topdir package)
197 "Return the name of the MANIFEST file for package PACKAGE. 166 "Return the name of the MANIFEST file for package PACKAGE.
198 Note that PACKAGE is a symbol, and not a string." 167 Note that PACKAGE is a symbol, and not a string."
199 (let (dir) 168 (let ((dir (file-name-as-directory
200 (setq dir (expand-file-name "pkginfo" pkg-topdir)) 169 (expand-file-name "pkginfo" pkg-topdir))))
201 (expand-file-name (concat "MANIFEST." (symbol-name package)) dir) 170 (expand-file-name (concat "MANIFEST." (symbol-name package)) dir)))
202 ))
203 171
204 (defun package-admin-check-manifest (pkg-outbuf pkg-topdir) 172 (defun package-admin-check-manifest (pkg-outbuf pkg-topdir)
205 "Check for a MANIFEST.<package> file in the package distribution. 173 "Check for a MANIFEST.<package> file in the package distribution.
206 If it doesn't exist, create and write one. 174 If it doesn't exist, create and write one.
207 PKG-OUTBUF is the buffer that holds the output from `tar', and PKG-TOPDIR 175 PKG-OUTBUF is the buffer that holds the output from `tar', and PKG-TOPDIR
208 is the top-level directory under which the package was installed." 176 is the top-level directory under which the package was installed."
209 (let ( (manifest-buf " *pkg-manifest*") 177 (let ((manifest-buf " *pkg-manifest*")
210 old-case-fold-search regexp package-name pathname regexps) 178 (old-case-fold-search case-fold-search)
211 ;; Save and restore the case-fold-search status. 179 regexp package-name pathname regexps)
212 ;; We do this in case we have to screw with it (as it the case of
213 ;; case-insensitive filesystems such as MS Windows).
214 (setq old-case-fold-search case-fold-search)
215 (unwind-protect 180 (unwind-protect
216 (save-excursion ;; Probably redundant. 181 (save-excursion ;; Probably redundant.
217 (set-buffer (get-buffer pkg-outbuf)) ;; Probably already the 182 (set-buffer (get-buffer pkg-outbuf)) ;; Probably already the current buffer.
218 ;; current buffer.
219 (goto-char (point-min)) 183 (goto-char (point-min))
220 184
221 ;; Make filenames case-insensitive, if necessary 185 ;; Make filenames case-insensitive, if necessary
222 (if (eq system-type 'windows-nt) 186 (if (eq system-type 'windows-nt)
223 (setq case-fold-search t)) 187 (setq case-fold-search t))
224 188
225 ;; We really should compute the regexp. 189 (setq regexp (concat "\\bpkginfo"
226 ;; However, directory-sep-char is currently broken, but we need 190 (char-to-string directory-sep-char)
227 ;; functional code *NOW*. 191 "MANIFEST\\...*"))
228 (setq regexp "\\bpkginfo[\\/]MANIFEST\\...*")
229 192
230 ;; Look for the manifest. 193 ;; Look for the manifest.
231 (if (not (re-search-forward regexp nil t)) 194 (if (not (re-search-forward regexp nil t))
232 (progn 195 (progn
233 ;; We didn't find a manifest. Make one. 196 ;; We didn't find a manifest. Make one.
234 197
235 ;; Yuk. We weren't passed the package name, and so we have 198 ;; Yuk. We weren't passed the package name, and so we have
236 ;; to dig for it. Look for it as the subdirectory name below 199 ;; to dig for it. Look for it as the subdirectory name below
237 ;; "lisp", "man", "info", or "etc". 200 ;; "lisp", or "man".
238 ;; Here, we don't use a single regexp because we want to search 201 ;; Here, we don't use a single regexp because we want to search
239 ;; the directories for a package name in a particular order. 202 ;; the directories for a package name in a particular order.
240 ;; The problem is that packages could have directories like
241 ;; "etc/sounds/" or "etc/photos/" and we don't want to get
242 ;; these confused with the actual package name (although, in
243 ;; the case of "etc/sounds/", it's probably correct).
244 (if (catch 'done 203 (if (catch 'done
245 (let ( (dirs '("lisp" "info" "man" "etc")) rexp) 204 (let ((dirs '("lisp" "man"))
205 rexp)
246 (while dirs 206 (while dirs
247 (setq rexp (concat "\\b" (car dirs) 207 (setq rexp (concat "\\b" (car dirs)
248 "[\\/]\\([^\\/]+\\)[\//]")) 208 "[\\/]\\([^\\/]+\\)[\//]"))
249 (if (re-search-forward rexp nil t) 209 (if (re-search-forward rexp nil t)
250 (throw 'done t)) 210 (throw 'done t))
251 (setq dirs (cdr dirs)) 211 (setq dirs (cdr dirs)))))
252 )))
253 (progn 212 (progn
254 (setq package-name (buffer-substring (match-beginning 1) 213 (setq package-name (buffer-substring (match-beginning 1)
255 (match-end 1))) 214 (match-end 1)))
256 215
257 ;; Get and erase the manifest buffer 216 ;; Get and erase the manifest buffer
275 (progn 234 (progn
276 (setq pathname 235 (setq pathname
277 (buffer-substring 236 (buffer-substring
278 (match-beginning 1) 237 (match-beginning 1)
279 (match-end 1))) 238 (match-end 1)))
280 (throw 'found-path t) 239 (throw 'found-path t)))
281 )) 240 (setq regexps (cdr regexps))))
282 (setq regexps (cdr regexps))
283 )
284 )
285 (progn 241 (progn
286 ;; found a pathname -- add it to the manifest 242 ;; found a pathname -- add it to the manifest
287 ;; buffer 243 ;; buffer
288 (save-excursion 244 (save-excursion
289 (set-buffer manifest-buf) 245 (set-buffer manifest-buf)
290 (goto-char (point-max)) 246 (goto-char (point-max))
291 (insert pathname "\n") 247 (insert pathname "\n"))))
292 ) 248 (forward-line 1))
293 ))
294 (forward-line 1)
295 )
296 249
297 ;; Processed all lines. 250 ;; Processed all lines.
298 ;; Now, create the file, pkginfo/MANIFEST.<pkgname> 251 ;; Now, create the file, pkginfo/MANIFEST.<pkgname>
299 252
300 ;; We use `expand-file-name' instead of `concat', 253 ;; We use `expand-file-name' instead of `concat',
310 (save-excursion 263 (save-excursion
311 (set-buffer manifest-buf) 264 (set-buffer manifest-buf)
312 ;; Put the files in sorted order 265 ;; Put the files in sorted order
313 (if-fboundp 'sort-lines 266 (if-fboundp 'sort-lines
314 (sort-lines nil (point-min) (point-max)) 267 (sort-lines nil (point-min) (point-max))
315 (error 'unimplemented 268 (warn "`xemacs-base' not installed, MANIFEST.%s not sorted"
316 "`xemacs-base' not installed?")) 269 package-name))
317 ;; Write the file. 270 ;; Write the file.
318 ;; Note that using `write-region' *BYPASSES* any check 271 ;; Note that using `write-region' *BYPASSES* any check
319 ;; to see if XEmacs is currently editing/visiting the 272 ;; to see if XEmacs is currently editing/visiting the
320 ;; file. 273 ;; file.
321 (write-region (point-min) (point-max) pathname) 274 (write-region (point-min) (point-max) pathname))
322 ) 275 (kill-buffer manifest-buf))))))
323 (kill-buffer manifest-buf)
324 )
325 (progn
326 ;; We can't determine the package name from an extracted
327 ;; file in the tar output buffer.
328 ))
329 ))
330 )
331 ;; Restore old case-fold-search status 276 ;; Restore old case-fold-search status
332 (setq case-fold-search old-case-fold-search)) 277 (setq case-fold-search old-case-fold-search))))
333 ))
334 278
335 ;;;###autoload 279 ;;;###autoload
336 (defun package-admin-add-binary-package (file &optional pkg-dir) 280 (defun package-admin-add-binary-package (file &optional pkg-dir)
337 "Install a pre-bytecompiled XEmacs package into package hierarchy." 281 "Install a pre-bytecompiled XEmacs package into package hierarchy."
338 (interactive "fPackage tarball: ") 282 (interactive "fPackage tarball: ")
339 (let ((buf (get-buffer-create package-admin-temp-buffer)) 283 (let ((buf (get-buffer-create package-admin-temp-buffer))
340 (status 1) 284 (status 1)
341 start err-list 285 start err-list)
342 )
343 (setq pkg-dir (package-admin-get-install-dir 'unknown pkg-dir)) 286 (setq pkg-dir (package-admin-get-install-dir 'unknown pkg-dir))
344 ;; Ensure that the current directory doesn't change 287 ;; Ensure that the current directory doesn't change
345 (save-excursion 288 (save-excursion
346 (set-buffer buf) 289 (set-buffer buf)
347 ;; This is not really needed 290 ;; This is not really needed
359 (setq err-list package-admin-error-messages) 302 (setq err-list package-admin-error-messages)
360 (while err-list 303 (while err-list
361 (if (re-search-forward (car err-list) nil t) 304 (if (re-search-forward (car err-list) nil t)
362 (progn 305 (progn
363 (setq status 1) 306 (setq status 1)
364 (throw 'done nil) 307 (throw 'done nil)))
365 )) 308 (setq err-list (cdr err-list))))
366 (setq err-list (cdr err-list))
367 )
368 )
369 ;; Make sure that the MANIFEST file exists 309 ;; Make sure that the MANIFEST file exists
370 (package-admin-check-manifest buf pkg-dir) 310 (package-admin-check-manifest buf pkg-dir))))
371 )) 311 status))
372 )
373 status
374 ))
375 312
376 (defun package-admin-rmtree (directory) 313 (defun package-admin-rmtree (directory)
377 "Delete a directory and all of its contents, recursively. 314 "Delete a directory and all of its contents, recursively.
378 This is a feeble attempt at making a portable rmdir." 315 This is a feeble attempt at making a portable rmdir."
379 (setq directory (file-name-as-directory directory)) 316 (setq directory (file-name-as-directory directory))
404 (let (package-lispdir) 341 (let (package-lispdir)
405 (if (and (setq package-lispdir (expand-file-name "lisp" pkg-topdir)) 342 (if (and (setq package-lispdir (expand-file-name "lisp" pkg-topdir))
406 (setq package-lispdir (expand-file-name (symbol-name package) 343 (setq package-lispdir (expand-file-name (symbol-name package)
407 package-lispdir)) 344 package-lispdir))
408 (file-accessible-directory-p package-lispdir)) 345 (file-accessible-directory-p package-lispdir))
409 package-lispdir) 346 package-lispdir)))
410 ))
411 347
412 (defun package-admin-delete-binary-package (package pkg-topdir) 348 (defun package-admin-delete-binary-package (package pkg-topdir)
413 "Delete a binary installation of PACKAGE below directory PKG-TOPDIR. 349 "Delete a binary installation of PACKAGE below directory PKG-TOPDIR.
414 PACKAGE is a symbol, not a string." 350 PACKAGE is a symbol, not a string."
415 (let ( (tmpbuf " *pkg-manifest*") manifest-file package-lispdir dirs file) 351 (let (manifest-file package-lispdir dirs file)
416 (setq pkg-topdir (package-admin-get-install-dir package pkg-topdir)) 352 (setq pkg-topdir (package-admin-get-install-dir package pkg-topdir))
417 (setq manifest-file (package-admin-get-manifest-file pkg-topdir package)) 353 (setq manifest-file (package-admin-get-manifest-file pkg-topdir package))
418 (run-hook-with-args 'package-delete-hook package pkg-topdir) 354 (run-hook-with-args 'package-delete-hook package pkg-topdir)
419 (if (file-exists-p manifest-file) 355 (if (file-exists-p manifest-file)
420 (progn 356 (progn
421 ;; The manifest file exists! Use it to delete the old distribution. 357 ;; The manifest file exists! Use it to delete the old distribution.
422 (message "Removing old files for package \"%s\" ..." package) 358 (message "Removing old files for package \"%s\" ..." package)
423 (sit-for 0) 359 (sit-for 0)
424 (setq tmpbuf (get-buffer-create tmpbuf)) 360 (with-temp-buffer
425 (with-current-buffer tmpbuf
426 (buffer-disable-undo) 361 (buffer-disable-undo)
427 (erase-buffer) 362 (erase-buffer)
428 (insert-file-contents manifest-file) 363 (insert-file-contents manifest-file)
429 (goto-char (point-min)) 364 (goto-char (point-min))
430 365
452 (error nil))) ;; We may want to turn the error into a Warning? 387 (error nil))) ;; We may want to turn the error into a Warning?
453 (forward-line 1)) 388 (forward-line 1))
454 389
455 ;; Delete empty directories. 390 ;; Delete empty directories.
456 (if dirs 391 (if dirs
457 (let ( (orig-default-directory default-directory) 392 (progn
458 ;; directory files file 393 (mapc
459 ) 394 (lambda (dir)
460 ;; Make sure we preserve the existing `default-directory'. 395 (condition-case ()
461 ;; JV, why does this change the default directory? Does it indeed? 396 (delete-directory dir)))
462 (unwind-protect 397 dirs)))
463 (progn
464 ;; Warning: destructive sort!
465 (setq dirs (nreverse (sort dirs 'string<)))
466 ; ;; For each directory ...
467 ; (while dirs
468 ; (setq directory (file-name-as-directory (car dirs)))
469 ; (setq files (directory-files directory))
470 ; ;; Delete the directory if it's empty.
471 ; (if (catch 'done
472 ; (while files
473 ; (setq file (car files))
474 ; (if (and (not (string= file "."))
475 ; (not (string= file "..")))
476 ; (throw 'done nil))
477 ; (setq files (cdr files))
478 ; )
479 ; t)
480 ; (
481 ; (delete-directory directory))
482 ; (setq dirs (cdr dirs))
483 ; )
484 ;; JV, On all OS's that I know of delete-directory fails on
485 ;; on non-empty dirs anyway
486 (mapc
487 (lambda (dir)
488 (condition-case ()
489 (delete-directory dir)))
490 dirs))
491 (setq default-directory orig-default-directory)
492 )))
493 )
494 (kill-buffer tmpbuf)
495 ;; Delete the MANIFEST file 398 ;; Delete the MANIFEST file
496 ;; (set-file-modes manifest-file 438) ;; 438 -> #o666 399 ;; (set-file-modes manifest-file 438) ;; 438 -> #o666
497 ;; Note. Packages can have MANIFEST in MANIFEST. 400 ;; Note. Packages can have MANIFEST in MANIFEST.
498 (condition-case () 401 (condition-case ()
499 (delete-file manifest-file) 402 (delete-file manifest-file)
500 (error nil)) ;; Do warning? 403 (error nil)) ;; Do warning?
501 (message "Removing old files for package \"%s\" ... done" package)) 404 (message "Removing old files for package \"%s\" ... done" package)))
502 ;; The manifest file doesn't exist. Fallback to just deleting the 405 ;; The manifest file doesn't exist. Fallback to just deleting the
503 ;; package-specific lisp directory, if it exists. 406 ;; package-specific lisp directory, if it exists.
504 ;; 407 ;;
505 ;; Delete old lisp directory, if any 408 ;; Delete old lisp directory, if any
506 ;; Gads, this is ugly. However, we're not supposed to use `concat' 409 ;; Gads, this is ugly. However, we're not supposed to use `concat'
507 ;; in the name of portability. 410 ;; in the name of portability.
508 (when (setq package-lispdir (package-admin-get-lispdir pkg-topdir 411 (setq package-lispdir (package-admin-get-lispdir pkg-topdir package))
509 package)) 412 (message "Removing old lisp directory \"%s\" ..." package-lispdir)
510 (message "Removing old lisp directory \"%s\" ..." 413 (sit-for 0)
511 package-lispdir) 414 (package-admin-rmtree package-lispdir)
512 (sit-for 0) 415 (message "Removing old lisp directory \"%s\" ... done" package-lispdir))
513 (package-admin-rmtree package-lispdir)
514 (message "Removing old lisp directory \"%s\" ... done"
515 package-lispdir)
516 ))
517 ;; Delete the package from the database of installed packages. 416 ;; Delete the package from the database of installed packages.
518 (package-delete-name package))) 417 (package-delete-name package)))
519 418
520 (provide 'package-admin) 419 (provide 'package-admin)
521 420