diff lisp/package-get.el @ 398:74fd4e045ea6 r21-2-29

Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents 6719134a07c2
children a86b2b5e0111
line wrap: on
line diff
--- a/lisp/package-get.el	Mon Aug 13 11:12:06 2007 +0200
+++ b/lisp/package-get.el	Mon Aug 13 11:13:30 2007 +0200
@@ -32,7 +32,7 @@
 ;;	Retrieve a package and any other required packages from an archive
 ;;
 ;;
-;; Note (JV): Most of this no longer aplies!
+;; Note (JV): Most of this no longer applies!
 ;;
 ;; The idea:
 ;;	A new XEmacs lisp-only release is generated with the following steps:
@@ -180,37 +180,56 @@
 			 (list :tag "Remote" host-name directory) ))
   :group 'package-get)
 
+;;;###autoload
 (defcustom package-get-download-sites
   '(
     ;; North America
     ("xemacs.org" "ftp.xemacs.org" "pub/xemacs/packages")
-    ("cso.uiuc.edu" "ftp.cso.uiuc.edu" "pub/packages/xemacs/packages")
+    ("crc.ca (Canada)" "ftp.crc.ca" "pub/packages/editors/xemacs/packages")
+    ("ualberta.ca (Canada)" "sunsite.ualberta.ca" "pub/Mirror/xemacs/packages")
+    ("uiuc.edu (United States)" "uiarchive.uiuc.edu" "pub/packages/xemacs/packages")
+    ("unc.edu (United States)" "metalab.unc.edu" "pub/packages/editors/xemacs/packages")
+    ("utk.edu (United States)" "ftp.sunsite.utk.edu" "pub/xemacs/packages")
 
     ;; South America
-    ("unicamp.br" "ftp.unicamp.br" "pub/xemacs/packages")
+    ("unicamp.br (Brazil)" "ftp.unicamp.br" "pub/xemacs/packages")
 
     ;; Europe
-    ("sunsite.cnlab-switch.ch" "sunsite.cnlab-switch.ch" "mirror/xemacs/packages")
-    ("tu-darmstadt.de" "ftp.tu-darmstadt.de" "pub/editors/xemacs/packages")
-    ("sunsite.auc.dk" "sunsite.auc.dk" "pub/emacs/xemacs/packages")
-    ("pasteur.fr" "ftp.pasteur.fr" "pub/computing/xemacs/packages")
-    ("cenatls.cena.dgac.fr" "ftp.cenatls.cena.dgac.fr" "pub/Emacs/xemacs/packages")
-    ("kfki.hu" "ftp.kfki.hu" "pub/packages/xemacs/packages")
-    ("uniroma2.it" "ftp.uniroma2.it" "unix/misc/dist/XEMACS/packages")
-    ("icm.edu.pl" "ftp.icm.edu.pl" "pub/unix/editors/xemacs/packages")
-    ("sunet.se" "ftp.sunet.se" "pub/gnu/xemacs/packages")
-    ("doc.ic.ac.uk" "sunsite.doc.ic.ac.uk" "packages/xemacs/packages")
-    ("srcc.msu.su" "ftp1.srcc.msu.su" "mirror/ftp.xemacs.org/packages")
+    ("tuwien.ac.at (Austria)" "gd.tuwien.ac.at" "editors/xemacs/packages")
+    ("auc.dk (Denmark)" "sunsite.auc.dk" "pub/emacs/xemacs/packages")
+    ("doc.ic.ac.uk (England)" "sunsite.doc.ic.ac.uk" "packages/xemacs/packages")
+    ("funet.fi (Finland)" "ftp.funet.fi" "pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/packages")
+    ("cenatls.cena.dgac.fr (France)" "ftp.cenatls.cena.dgac.fr" "Emacs/xemacs/packages")
+    ("pasteur.fr (France)" "ftp.pasteur.fr" "pub/computing/xemacs/packages")
+    ("tu-darmstadt.de (Germany)" "ftp.tu-darmstadt.de" "pub/editors/xemacs/packages")
+    ("kfki.hu (Hungary)" "ftp.kfki.hu" "pub/packages/xemacs/packages")
+    ("eunet.ie (Ireland)" "ftp.eunet.ie" "mirrors/ftp.xemacs.org/pub/xemacs/packages")
+    ("uniroma2.it (Italy)" "ftp.uniroma2.it" "unix/misc/dist/XEMACS/packages")
+    ("uio.no (Norway)" "sunsite.uio.no" "pub/xemacs/packages")
+    ("icm.edu.pl (Poland)" "ftp.icm.edu.pl" "pub/unix/editors/xemacs/packages")
+    ("srcc.msu.su (Russia)" "ftp.srcc.msu.su" "mirror/ftp.xemacs.org/packages")
+    ("sunet.se (Sweden)" "ftp.sunet.se" "pub/gnu/xemacs/packages")
+    ("cnlab-switch.ch (Switzerland)" "sunsite.cnlab-switch.ch" "mirror/xemacs/packages")
 
     ;; Asia
-    ("usyd.edu.au" "ftp.usyd.edu.au" "pub/Xemacs/packages")
-    ("netlab.is.tsukuba.ac.jp" "ftp.netlab.is.tsukuba.ac.jp" "pub/GNU/xemacs/packages")
-    ("jaist.ac.jp" "ftp.jaist.ac.jp" "pub/GNU/xemacs/packages")
-    ("ring.aist.go.jp" "ring.aist.go.jp" "pub/text/xemacs/packages")
-    ("ring.asahi-net.or.jp" "ring.asahi-net.or.jp" "pub/text/xemacs/packages")
-    ("SunSITE.sut.ac.jp" "SunSITE.sut.ac.jp" "pub/archives/packages/xemacs/packages")
-    ("dti.ad.jp" "ftp.dti.ad.jp" "pub/unix/editor/xemacs/packages")
-    ("kreonet.re.kr" "ftp.kreonet.re.kr" "pub/tools/emacs/xemacs/packages")
+    ("aist.go.jp (Japan)" "ring.aist.go.jp" "pub/text/xemacs/packages")
+    ("asahi-net.or.jp (Japan)" "ring.asahi-net.or.jp" "pub/text/xemacs/packages")
+    ("dti.ad.jp (Japan)" "ftp.dti.ad.jp" "pub/unix/editor/xemacs/packages")
+    ("jaist.ac.jp (Japan)" "ftp.jaist.ac.jp" "pub/GNU/xemacs/packages")
+    ("nucba.ac.jp (Japan)" "mirror.nucba.ac.jp" "mirror/xemacs/packages")
+    ("sut.ac.jp (Japan)" "sunsite.sut.ac.jp" "pub/archives/packages/xemacs/packages")
+    ("tsukuba.ac.jp (Japan)" "ftp.netlab.is.tsukuba.ac.jp" "pub/GNU/xemacs/packages")
+    ("kreonet.re.kr (Korea)" "ftp.kreonet.re.kr" "pub/tools/emacs/xemacs/packages")
+    ("nctu.edu.tw (Taiwan)" "coda.nctu.edu.tw" "Editors/xemacs/packages")
+
+    ;; Africa
+    ("sun.ac.za (South Africa)" "ftp.sun.ac.za" "xemacs/packages")
+
+    ;; Middle East
+    ("isu.net.sa (Saudi Arabia)" "ftp.isu.net.sa" "pub/mirrors/ftp.xemacs.org/packages")
+
+    ;; Australia
+    ("aarnet.edu.au (Australia)" "mirror.aarnet.edu.au" "pub/xemacs/packages")
     )
   "*List of remote sites available for downloading packages.
 List format is '(site-description site-name directory-on-site).
@@ -224,7 +243,7 @@
   :group 'package-get)
 
 (defcustom package-get-remove-copy t
-  "*After copying and installing a package, if this is T, then remove the
+  "*After copying and installing a package, if this is t, then remove the
 copy.  Otherwise, keep it around."
   :type 'boolean
   :group 'package-get)
@@ -239,6 +258,10 @@
   :type 'file
   :group 'package-get)
 
+(defvar package-get-user-index-filename
+  (paths-construct-path (list user-init-directory package-get-base-filename))
+  "Name for the user-specific location of the package-get database file.")
+
 (defcustom package-get-always-update nil
   "*If Non-nil always make sure we are using the latest package index (base).
 Otherwise respect the `force-current' argument of `package-get-require-base'."
@@ -261,11 +284,16 @@
 (defun package-get-download-menu ()
   "Build the `Add Download Site' menu."
   (mapcar (lambda (site)
-            (vector (car site)
-               `(package-ui-add-site (quote ,(cdr site)))
-		    :style 'toggle :selected
-		    `(member (quote ,(cdr site)) package-get-remote)))
-          package-get-download-sites))
+	    (vector (car site)
+		    `(if (member (quote ,(cdr site))
+				 package-get-remote)
+			 (setq package-get-remote
+			       (delete (quote ,(cdr site)) package-get-remote))
+		       (package-ui-add-site (quote ,(cdr site))))
+		    :style 'toggle
+		    :selected `(member (quote ,(cdr site))
+				       package-get-remote)))
+	  package-get-download-sites))
 
 ;;;###autoload
 (defun package-get-require-base (&optional force-current)
@@ -328,24 +356,22 @@
   "Locate the package-get index file.  Do not return remote paths if NO-REMOTE
 is non-nil."
   (or (package-get-locate-file package-get-base-filename t no-remote)
-      (locate-data-file package-get-base-filename)
-      package-get-base-filename))
-
-(defvar package-get-user-package-location user-init-directory)
+      (if (file-exists-p package-get-user-index-filename)
+	  package-get-user-index-filename)))
 
 (defun package-get-maybe-save-index (filename)
   "Offer to save the current buffer as the local package index file,
 if different."
   (let ((location (package-get-locate-index-file t)))
     (unless (and filename (equal filename location))
-      (unless (equal (md5 (current-buffer))
-		     (with-temp-buffer
-		       (insert-file-contents location)
-		       (md5 (current-buffer))))
-	(unless (file-writable-p location)
-	  (setq location (expand-file-name package-get-base-filename
-		(expand-file-name "etc/" package-get-user-package-location))))
-	(when (y-or-n-p (concat "Update package index in" location "? "))
+      (unless (and location
+		   (equal (md5 (current-buffer))
+			  (with-temp-buffer
+			    (insert-file-contents-literally location)
+			    (md5 (current-buffer)))))
+	(unless (and location (file-writable-p location))
+	  (setq location package-get-user-index-filename))
+	(when (y-or-n-p (concat "Update package index in " location "? "))
 	  (write-file location))))))
       
 
@@ -425,7 +451,7 @@
                                          "package-get DB verification? ")))))
                       (t nil)))))
           (error "Package-get PGP signature failed to verify"))
-      ;; ToDo: We shoud call package-get-maybe-save-index on the region
+      ;; ToDo: We should call package-get-maybe-save-index on the region
       (package-get-update-base-entries content-beg content-end)
       (message "Updated package-get database"))))
 
@@ -1001,6 +1027,10 @@
 			 (package-get-info-prop (car this-package) 'version))))
 	    (setq this-package (cdr this-package)))))
       (setq packages (cdr packages)))
+    (when (interactive-p)
+      (if found
+          (message "%S" found)
+        (message "No appropriate package found")))
     found))
 
 ;;