X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fpackage-get.el;h=5ae5de3618ee21de2fe9e2fb2f5d4d9488589021;hb=1a5e625ffcc6b2e9a9828a89763c062a0b09b361;hp=3acf44e93d74fea56ac00d6213e4e20b37c53fe1;hpb=f3ec20f455f3f1212d2c5ee4cadc984330da9c38;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/package-get.el b/lisp/package-get.el index 3acf44e..5ae5de3 100644 --- a/lisp/package-get.el +++ b/lisp/package-get.el @@ -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: @@ -68,7 +68,7 @@ ;; vm - a mail reader ;; [] Always install ;; [] Needs updating -;; [] Required by other [packages] +;; [] Required by other [packages] ;; ;; Where `[]' indicates a toggle box ;; @@ -79,7 +79,7 @@ ;; - "Required by other" means some other packages are going to force ;; this to be installed. Clicking on [packages] gives a list ;; of packages that require this. -;; +;; ;; The `package-get-base' should be installed in a file in ;; `data-directory'. The `package-get-here' should be installed in ;; site-lisp. Both are then read at run time. @@ -112,7 +112,8 @@ "Automatic Package Fetcher and Installer." :prefix "package-get" :group 'package-tools) - + +;;;###autoload (defvar package-get-base nil "List of packages that are installed at this site. For each element in the alist, car is the package name and the cdr is @@ -179,37 +180,66 @@ order until the package is found. As a special case, `site-name' can be (list :tag "Remote" host-name directory) )) :group 'package-get) +;;;###autoload (defcustom package-get-download-sites '( ;; North America + ("Pre-Releases" "ftp.xemacs.org" "pub/xemacs/beta/experimental/packages") ("xemacs.org" "ftp.xemacs.org" "pub/xemacs/packages") - ("cso.uiuc.edu" "ftp.cso.uiuc.edu" "pub/packages/xemacs/packages") + ("ca.xemacs.org (Canada)" "ftp.ca.xemacs.org" "pub/Mirror/xemacs/packages") + ("crc.ca (Canada)" "ftp.crc.ca" "pub/packages/editors/xemacs/packages") + ("us.xemacs.org (United States)" "ftp.us.xemacs.org" "pub/xemacs/packages") + ("ibiblio.org (United States)" "ibiblio.org" "pub/packages/editors/xemacs/packages") + ("stealth.net (United States)" "ftp.stealth.net" "pub/mirrors/ftp.xemacs.org/pub/xemacs/packages") + ;("uiuc.edu (United States)" "uiarchive.uiuc.edu" "pub/packages/xemacs/packages") ;; South America - ("unicamp.br" "ftp.unicamp.br" "pub/xemacs/packages") + ("br.xemacs.org (Brazil)" "ftp.br.xemacs.org" "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") + ("at.xemacs.org (Austria)" "ftp.at.xemacs.org" "editors/xemacs/packages") + ("be.xemacs.org (Belgium)" "ftp.be.xemacs.org" "xemacs/packages") + ("cz.xemacs.org (Czech Republic)" "ftp.cz.xemacs.org" "MIRRORS/ftp.xemacs.org/pub/xemacs/packages") + ("dk.xemacs.org (Denmark)" "ftp.dk.xemacs.org" "pub/emacs/xemacs/packages") + ("fi.xemacs.org (Finland)" "ftp.fi.xemacs.org" "pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/packages") + ("fr.xemacs.org (France)" "ftp.fr.xemacs.org" "pub/xemacs/packages") + ("pasteur.fr (France)" "ftp.pasteur.fr" "pub/computing/xemacs/packages") + ("de.xemacs.org (Germany)" "ftp.de.xemacs.org" "pub/ftp.xemacs.org/tux/xemacs/packages") + ("tu-darmstadt.de (Germany)" "ftp.tu-darmstadt.de" "pub/editors/xemacs/packages") + ;("hu.xemacs.org (Hungary)" "ftp.hu.xemacs.org" "pub/packages/xemacs/packages") + ("ie.xemacs.org (Ireland)" "ftp.ie.xemacs.org" "mirrors/ftp.xemacs.org/pub/xemacs/packages") + ("it.xemacs.org (Italy)" "ftp.it.xemacs.org" "unix/packages/XEMACS/packages") + ("no.xemacs.org (Norway)" "ftp.no.xemacs.org" "pub/xemacs/packages") + ("pl.xemacs.org (Poland)" "ftp.pl.xemacs.org" "pub/unix/editors/xemacs/packages") + ("ru.xemacs.org (Russia)" "ftp.ru.xemacs.org" "pub/xemacs/packages") + ("sk.xemacs.org (Slovakia)" "ftp.sk.xemacs.org" "pub/mirrors/xemacs/packages") + ("se.xemacs.org (Sweden)" "ftp.se.xemacs.org" "pub/gnu/xemacs/packages") + ("ch.xemacs.org (Switzerland)" "ftp.ch.xemacs.org" "mirror/xemacs/packages") + ("uk.xemacs.org (United Kingdom)" "ftp.uk.xemacs.org" "sites/ftp.xemacs.org/pub/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") + ("jp.xemacs.org (Japan)" "ftp.jp.xemacs.org" "pub/GNU/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") + ("kr.xemacs.org (Korea)" "ftp.kr.xemacs.org" "pub/tools/emacs/xemacs/packages") + ;("tw.xemacs.org (Taiwan)" "ftp.tw.xemacs.org" "Editors/xemacs/packages") + + ;; Africa + ("za.xemacs.org (South Africa)" "ftp.za.xemacs.org" "mirrorsites/ftp.xemacs.org/packages") + + ;; Middle East + ("sa.xemacs.org (Saudi Arabia)" "ftp.sa.xemacs.org" "pub/mirrors/ftp.xemacs.org/xemacs/packages") + + ;; Australia + ("au.xemacs.org (Australia)" "ftp.au.xemacs.org" "pub/xemacs/packages") + ("aarnet.edu.au (Australia)" "mirror.aarnet.edu.au" "pub/xemacs/packages") + + ;; Oceania + ("nz.xemacs.org (New Zealand)" "ftp.nz.xemacs.org" "mirror/ftp.xemacs.org/packages") ) "*List of remote sites available for downloading packages. List format is '(site-description site-name directory-on-site). @@ -219,11 +249,11 @@ is the directory on the site in which packages may be found. This variable is used to initialize `package-get-remote', the variable actually used to specify package download sites." :tag "Package download sites" - :type '(repeat (list hostname directory)) + :type '(repeat (list (string :tag "Name") host-name directory)) :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) @@ -238,13 +268,17 @@ with respect to `package-get-remote', or an absolute path." :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'." :type 'boolean :group 'package-get) -(defcustom package-get-require-signed-base-updates t +(defcustom package-get-require-signed-base-updates nil "*If set to a non-nil value, require explicit user confirmation for updates to the package-get database which cannot have their signature verified via PGP. When nil, updates which are not PGP signed are allowed without confirmation." @@ -260,11 +294,17 @@ When nil, updates which are not PGP signed are allowed without confirmation." (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) @@ -327,26 +367,27 @@ If NO-REMOTE is non-nil never search remote locations." "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) + (if (file-exists-p package-get-user-index-filename) + package-get-user-index-filename) (locate-data-file package-get-base-filename) - package-get-base-filename)) - -(defvar package-get-user-package-location user-init-directory) + (error "Can't locate a package index file."))) (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 "? ")) - (write-file 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 "? ")) + (let ((coding-system-for-write 'binary)) + (write-file location))))))) + ;;;###autoload (defun package-get-update-base (&optional db-file force-current) @@ -371,7 +412,7 @@ Unless FORCE-CURRENT is non-nil never try to update the database." (save-excursion (set-buffer buf) (erase-buffer buf) - (insert-file-contents-internal db-file) + (insert-file-contents-literally db-file) (package-get-update-base-from-buffer buf) (if (file-remote-p db-file) (package-get-maybe-save-index db-file))) @@ -424,15 +465,15 @@ used interactively, for example from a mail or news buffer." "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")))) -(defun package-get-update-base-entries (beg end) +(defun package-get-update-base-entries (start end) "Update the package-get database with the entries found between -BEG and END in the current buffer." +START and END in the current buffer." (save-excursion - (goto-char beg) + (goto-char start) (if (not (re-search-forward "^(package-get-update-base-entry" nil t)) (error "Buffer does not contain package-get database entries")) (beginning-of-line) @@ -488,19 +529,18 @@ Query for a version if GET-VERSION is non-nil. Return package name as a symbol instead of a string if PACKAGE-SYMBOL is non-nil. The return value is suitable for direct passing to `interactive'." (package-get-require-base t) - (let ( (table (mapcar '(lambda (item) - (let ( (name (symbol-name (car item))) ) - (cons name name) - )) - package-get-base)) - package package-symbol default-version version) + (let ((table (mapcar #'(lambda (item) + (let ((name (symbol-name (car item)))) + (cons name name))) + package-get-base)) + package package-symbol default-version version) (save-window-excursion (setq package (completing-read "Package: " table nil t)) (setq package-symbol (intern package)) (if get-version (progn - (setq default-version - (package-get-info-prop + (setq default-version + (package-get-info-prop (package-get-info-version (package-get-info-find-package package-get-base package-symbol) nil) @@ -515,8 +555,7 @@ The return value is suitable for direct passing to `interactive'." ) (if package-symbol (list package-symbol) - (list package))) - ))) + (list package)))))) ;;;###autoload (defun package-get-delete-package (package &optional pkg-topdir) @@ -537,7 +576,8 @@ This is just an interactive wrapper for `package-admin-delete-binary-package'." (if (not (package-get (car pkg) nil 'never)) (throw 'exit nil) ;; Bail out if error detected )) - packages-package-list))) + packages-package-list)) + (package-net-update-installed-db)) ;;;###autoload (defun package-get-all (package version &optional fetched-packages install-dir) @@ -612,7 +652,6 @@ required by PACKAGES." (mapcar #'(lambda (reqd) (let* ((reqd-package (package-get-package-provider reqd)) - (reqd-version (cadr reqd-package)) (reqd-name (car reqd-package))) (if (null reqd-name) (error "Unable to find a provider for %s" reqd)) @@ -679,7 +718,7 @@ package is already installed. Valid values for CONFLICT are: INSTALL-DIR, if non-nil, specifies the package directory where fetched packages should be installed. -The value of `package-get-base' is used to determine what files should +The value of `package-get-base' is used to determine what files should be retrieved. The value of `package-get-remote' is used to determine where a package should be retrieved from. The sites are tried in order so one is better off listing easily reached sites first. @@ -787,7 +826,7 @@ successfully installed but errors occurred during initialization, or current-dir-entry current-filename)) ;; Get it (setq full-package-filename dest-filename) - (message "Retrieving package `%s' ..." + (message "Retrieving package `%s' ..." current-filename) (sit-for 0) (copy-file (package-get-remote-filename current-dir-entry @@ -818,9 +857,7 @@ successfully installed but errors occurred during initialization, or ;; Doing it with XEmacs removes the need for an external md5 program (message "Validating checksum for `%s'..." package) (sit-for 0) (with-temp-buffer - ;; What ever happened to i-f-c-literally - (let (file-name-handler-alist) - (insert-file-contents-internal full-package-filename)) + (insert-file-contents-literally full-package-filename) (if (not (string= (md5 (current-buffer)) (package-get-info-prop this-package 'md5sum))) @@ -840,6 +877,7 @@ successfully installed but errors occurred during initialization, or (if (package-get-init-package (package-admin-get-lispdir install-dir package)) (progn + (run-hook-with-args 'package-install-hook package install-dir) (message "Added package `%s'" package) (sit-for 0) ) @@ -873,7 +911,7 @@ returned. To access fields returned from this, use `package-get-info-version' to return information about particular a -version. Use `package-get-info-find-prop' to find particular property +version. Use `package-get-info-find-prop' to find particular property from a version returned by `package-get-info-version'." (interactive "xPackage list: \nsPackage Name: ") (if which @@ -885,7 +923,7 @@ from a version returned by `package-get-info-version'." (defun package-get-info-version (package version) "In PACKAGE, return the plist associated with a particular VERSION of the package. PACKAGE is typically as returned by - `package-get-info-find-package'. If VERSION is nil, then return the + `package-get-info-find-package'. If VERSION is nil, then return the first (aka most recent) version. Use `package-get-info-find-prop' to retrieve a particular property from the value returned by this." (interactive (package-get-interactive-package-query t t)) @@ -925,7 +963,7 @@ Returns the modified PACKAGE-LIST. Any missing fields are created." (defun package-get-staging-dir (filename) "Return a good place to stash FILENAME when it is retrieved. Use `package-get-dir' for directory to store stuff. -Creates `package-get-dir' it it doesn't exist." +Creates `package-get-dir' if it doesn't exist." (interactive "FPackage filename: ") (if (not (file-exists-p package-get-dir)) (make-directory package-get-dir)) @@ -941,15 +979,19 @@ It first checks if FILENAME already is a remote filename. If it is not, then it uses the (car search) as the remote site-name and the (cadr search) as the remote-directory and concatenates filename. In other words - site-name:remote-directory/filename + site-name:remote-directory/filename. + +If (car search) is nil, (cadr search is interpreted as a local directory). " - (if (efs-ftp-path filename) + (if (file-remote-p filename) filename (let ((dir (cadr search))) - (concat (if (string-match "@" (car search)) - "/" - "/anonymous@") - (car search) ":" + (concat (when (car search) + (concat + (if (string-match "@" (car search)) + "/" + "/anonymous@") + (car search) ":")) (if (string-match "/$" dir) dir (concat dir "/")) @@ -958,7 +1000,7 @@ words (defun package-get-installedp (package version) "Determine if PACKAGE with VERSION has already been installed. -I'm not sure if I want to do this by searching directories or checking +I'm not sure if I want to do this by searching directories or checking some built in variables. For now, use packages-package-list." ;; Use packages-package-list which contains name and version (equal (plist-get @@ -970,7 +1012,7 @@ some built in variables. For now, use packages-package-list." (defun package-get-package-provider (sym &optional force-current) "Search for a package that provides SYM and return the name and version. Searches in `package-get-base' for SYM. If SYM is a - consp, then it must match a corresponding (provide (SYM VERSION)) from + consp, then it must match a corresponding (provide (SYM VERSION)) from the package. If FORCE-CURRENT is non-nil make sure the database is up to date. This might @@ -996,6 +1038,10 @@ lead to Emacs accessing remote sites." (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)) ;; @@ -1011,20 +1057,19 @@ lead to Emacs accessing remote sites." "Fetch and install the latest versions of all customized packages." (interactive) (package-get-require-base t) - ;; Load a fresh copy - (load "package-get-custom.el") (mapcar (lambda (pkg) (if (eval (intern (concat (symbol-name (car pkg)) "-package"))) (package-get (car pkg) nil)) t) - package-get-base)) + package-get-base) + (package-net-update-installed-db)) (defun package-get-ever-installed-p (pkg &optional notused) (string-match "-package$" (symbol-name pkg)) - (custom-initialize-set - pkg - (if (package-get-info-find-package - packages-package-list + (custom-initialize-set + pkg + (if (package-get-info-find-package + packages-package-list (intern (substring (symbol-name pkg) 0 (match-beginning 0)))) t))) @@ -1037,7 +1082,7 @@ lead to Emacs accessing remote sites." (custom-var (intern (concat (symbol-name package) "-package"))) (description (plist-get props 'description))) (when (not (memq group package-get-custom-groups)) - (setq package-get-custom-groups (cons package + (setq package-get-custom-groups (cons group package-get-custom-groups)) (eval `(defgroup ,group nil ,(concat category " package group")