;; Copyright (C) 1998 by Pete Ware
;; Copyright (C) 2002 Ben Wing.
-;; Copyright (C) 2003 - 2012 Steve Youngs
+;; Copyright (C) 2003 - 2015 Steve Youngs
;; Author: Pete Ware <ware@cis.ohio-state.edu>
;; Heavy-Modifications: Greg Klanderman <greg@alphatech.com>
;; Retrieve a package and any other required packages from an archive
;;
;;
-;; Note (JV): Most of this no longer applies!
+;; Note (JV): Most of this no longer applies!
;; Note (SY): Definitely no longer applies, but I'm leaving these
;; comments here because there are some nifty ideas here.
;;
:group 'package-get)
;;;###autoload
-(defcustom package-get-package-index-file-location
- (car (split-path (or (getenv "EMACSPACKAGEPATH") user-init-directory)))
+(defcustom package-get-package-index-file-location
+ (car (split-path (or (getenv "EMACSPACKAGEPATH") user-packages-topdir)))
"*The directory where the package-index file can be found."
:type 'directory
:group 'package-get)
;;;###autoload
-(defcustom package-get-install-to-user-init-directory nil
- "*If non-nil install packages under `user-init-directory'."
+(defcustom package-get-install-to-user-directory nil
+ "*If non-nil install packages under `user-packages-topdir'."
:type 'boolean
:group 'package-get)
+(defvaralias 'package-get-install-to-user-init-directory
+ 'package-get-install-to-user-directory)
+
(define-widget 'host-name 'string
"A Host name."
:tag "Host")
+(define-widget 'url-scheme 'string
+ "A URL protocol scheme."
+ :tag "URL-Scheme")
+
(defcustom package-get-remote nil
"*The remote site to contact for downloading packages.
-Format is '(site-name directory-on-site). As a special case, `site-name'
-can be `nil', in which case `directory-on-site' is treated as a local
-directory."
+
+Format is '(site-name directory-on-site scheme). As a special case,
+`site-name' can be `nil', in which case `directory-on-site' is treated
+as a local directory."
:tag "Package repository"
:type '(set (choice (const :tag "None" nil)
(list :tag "Local" (const :tag "Local" nil) directory)
- (list :tag "Remote" host-name directory)))
+ (list :tag "Remote" host-name directory url-scheme)))
:group 'package-get)
+(defvar package-get-have-curl (featurep 'ffi-curl)
+ "Non-nil when FFI and curl is available.")
+
;;;###autoload
(defcustom package-get-download-sites
- '(
- ;; Main XEmacs Site (ftp.xemacs.org)
+ `(,@(when package-get-have-curl
+ '(("SXEmacs XE pkg mirror"
+ "downloads.sxemacs.org" "xemacs-pkgs/packages" "http")))
("US (Main XEmacs Site)"
- "ftp.xemacs.org" "pub/xemacs/packages")
+ "ftp.xemacs.org" "pub/xemacs/packages" "ftp")
;; In alphabetical order of Country, our mirrors...
- ("Argentina (xmundo.net)" "xemacs.xmundo.net" "pub/mirrors/xemacs/packages")
- ("Australia (aarnet.edu.au)" "mirror.aarnet.edu.au" "pub/xemacs/packages")
- ("Australia (au.xemacs.org)" "ftp.au.xemacs.org" "pub/xemacs/packages")
- ("Austria (at.xemacs.org)" "ftp.at.xemacs.org" "editors/xemacs/packages")
- ("Belgium (be.xemacs.org)" "ftp.be.xemacs.org" "xemacs/packages")
- ("Brazil (br.xemacs.org)" "ftp.br.xemacs.org" "pub/xemacs/packages")
- ("Canada (ca.xemacs.org)" "ftp.ca.xemacs.org" "pub/Mirror/xemacs/packages")
- ("Canada (nrc.ca)" "ftp.nrc.ca" "pub/packages/editors/xemacs/packages")
- ;; no anonymous ftp available, uncomment when updating website
- ;; with
- ;; xemacs-builds/adrian/website/package-get-2-download-sites.el
-; ("Chile (cl.xemacs.org)" "ftp.cl.xemacs.org" "packages")
- ("China (ftp.cn.xemacs.org)" "ftp.cn.xemacs.org" "pub/xemacs/packages")
- ("Czech Republic (cz.xemacs.org)" "ftp.cz.xemacs.org" "MIRRORS/ftp.xemacs.org/pub/xemacs/packages")
- ("Denmark (dk.xemacs.org)" "ftp.dk.xemacs.org" "xemacs/packages")
- ("Finland (fi.xemacs.org)" "ftp.fi.xemacs.org" "pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/packages")
- ("France (fr.xemacs.org)" "ftp.fr.xemacs.org" "pub/xemacs/packages")
- ("France (mirror.cict.fr)" "mirror.cict.fr" "xemacs/packages")
- ("France (pasteur.fr)" "ftp.pasteur.fr" "pub/computing/xemacs/packages")
- ("Germany (de.xemacs.org)" "ftp.de.xemacs.org" "pub/ftp.xemacs.org/tux/xemacs/packages")
- ("Greece (gr.xemacs.org)" "ftp.gr.xemacs.org" "mirrors/XEmacs/ftp/packages")
- ("Hong Kong (hk.xemacs.org)" "ftp.hk.xemacs.org" "pub/xemacsftp/packages")
- ("Ireland (ie.xemacs.org)" "ftp.ie.xemacs.org" "mirrors/ftp.xemacs.org/pub/xemacs/packages")
- ("Ireland (heanet.ie)" "ftp.heanet.ie" "mirrors/ftp.xemacs.org/packages")
- ("Italy (it.xemacs.org)" "ftp.it.xemacs.org" "unix/packages/XEMACS/packages")
- ("Japan (dti.ad.jp)" "ftp.dti.ad.jp" "pub/unix/editor/xemacs/packages")
-; ("Japan (jaist.ac.jp)" "ftp.jaist.ac.jp" "pub/GNU/xemacs/packages")
- ("Japan (jp.xemacs.org)" "ftp.jp.xemacs.org" "pub/text/xemacs/packages")
-; ("Japan (nucba.ac.jp)" "mirror.nucba.ac.jp" "mirror/xemacs/packages")
- ("Korea (kr.xemacs.org)" "ftp.kr.xemacs.org" "pub/tools/emacs/xemacs/packages")
- ("Netherlands (nl.xemacs.org)" "ftp.nl.xemacs.org" "pub/xemacs/ftp/packages")
- ;; no anonymous ftp available, uncomment when updating website
- ;; with
- ;; xemacs-builds/adrian/website/package-get-2-download-sites.el
-; ("Netherlands (xemacsftp.digimirror.nl)" "xemacsftp.digimirror.nl" "packages")
- ("Norway (no.xemacs.org)" "ftp.no.xemacs.org" "pub/xemacs/packages")
- ("Portugal (pt.xemacs.org)" "ftp.pt.xemacs.org" "pub/MIRRORS/ftp.xemacs.org/packages")
- ("Russia (ru.xemacs.org)" "ftp.ru.xemacs.org" "pub/emacs/xemacs/packages")
- ("Saudi Arabia (sa.xemacs.org)" "ftp.sa.xemacs.org" "pub/xemacs.org/packages")
- ("Sweden (se.xemacs.org)" "ftp.se.xemacs.org" "pub/gnu/xemacs/packages")
- ("Switzerland (ch.xemacs.org)" "ftp.ch.xemacs.org" "mirror/xemacs/packages")
- ("Taiwan (ftp.tw.xemacs.org)" "ftp.tw.xemacs.org" "Unix/Editors/XEmacs/packages")
- ("UK (uk.xemacs.org)" "ftp.uk.xemacs.org" "sites/ftp.xemacs.org/pub/xemacs/packages")
- ("US (ibiblio.org)" "mirrors.ibiblio.org" "pub/mirrors/xemacs/packages")
- ("US (us.xemacs.org)" "ftp.us.xemacs.org" "pub/mirrors/xemacs/packages")
+ ;; Timing out
+ ("Belgium (be.xemacs.org)"
+ "ftp.be.xemacs.org" "xemacs/packages" "ftp")
+ ("Canada (ca.xemacs.org)"
+ "ftp.ca.xemacs.org" "pub/Mirror/xemacs/packages" "ftp")
+ ("Denmark (dk.xemacs.org)"
+ "ftp.dk.xemacs.org" "xemacs/packages" "ftp")
+ ("France (fr.xemacs.org)"
+ "ftp.fr.xemacs.org" "pub/xemacs/packages" "ftp")
+ ;; Temporary errors?
+ ("France (mirror.cict.fr)"
+ "mirror.cict.fr" "xemacs/packages" "ftp")
+ ("France (pasteur.fr)"
+ "ftp.pasteur.fr" "pub/computing/xemacs/packages" "ftp")
+ ;; Very outdated, experimental not updated since 2013
+ ("Germany (de.xemacs.org)"
+ "ftp.de.xemacs.org" "pub/ftp.xemacs.org/tux/xemacs/packages" "ftp")
+ ;; Timing out
+ ("Greece (gr.xemacs.org)"
+ "ftp.gr.xemacs.org" "mirrors/XEmacs/ftp/packages" "ftp")
+ ("Ireland (heanet.ie)"
+ "ftp.heanet.ie" "mirrors/ftp.xemacs.org/packages" "ftp")
+ ;; Timing out
+ ("Italy (it.xemacs.org)"
+ "ftp.it.xemacs.org" "unix/packages/XEMACS/packages" "ftp")
+ ;; Timing out
+ ("Japan (dti.ad.jp)"
+ "ftp.dti.ad.jp" "pub/unix/editor/xemacs/packages" "ftp")
+ ("Norway (no.xemacs.org)"
+ "ftp.no.xemacs.org" "pub/xemacs/packages" "ftp")
+ ("Portugal (pt.xemacs.org)"
+ "ftp.pt.xemacs.org" "pub/MIRRORS/ftp.xemacs.org/packages" "ftp")
+ ;; Timing out
+ ("Russia (ru.xemacs.org)"
+ "ftp.ru.xemacs.org" "pub/emacs/xemacs/packages" "ftp")
+ ("Saudi Arabia (sa.xemacs.org)"
+ "ftp.sa.xemacs.org" "pub/xemacs.org/packages" "ftp")
+ ("Sweden (se.xemacs.org)"
+ "ftp.se.xemacs.org" "pub/gnu/xemacs/packages" "ftp")
+ ("Switzerland (ch.xemacs.org)"
+ "ftp.ch.xemacs.org" "mirror/xemacs/packages" "ftp")
+ ("Taiwan (ftp.tw.xemacs.org)"
+ "ftp.tw.xemacs.org" "Unix/Editors/XEmacs/packages" "ftp")
+ ("UK (uk.xemacs.org)"
+ "ftp.uk.xemacs.org" "sites/ftp.xemacs.org/pub/xemacs/packages" "ftp")
+ ("US (ibiblio.org)"
+ "mirrors.ibiblio.org" "pub/mirrors/xemacs/packages" "ftp")
)
"*List of remote sites available for downloading packages.
-List format is '(site-description site-name directory-on-site).
-SITE-DESCRIPTION is a textual description of the site. SITE-NAME
-is the internet address of the download site. DIRECTORY-ON-SITE
-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."
+
+List format is '(site-description site-name directory-on-site url-scheme).
+SITE-DESCRIPTION is a textual description of the site. SITE-NAME is
+the internet address of the download site. DIRECTORY-ON-SITE is the
+directory on the site in which packages may be found. URL-SCHEME is
+the protocol such as `http', `ftp', etc. 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 (string :tag "Name") host-name directory))
+ :type '(repeat (list (string :tag "Name")
+ host-name directory url-scheme))
:group 'package-get)
;;;###autoload
(defcustom package-get-pre-release-download-sites
- '(
- ;; Main XEmacs Site (ftp.xemacs.org)
+ `(,@(when package-get-have-curl
+ '(("SXEmacs XE pkg Pre-Releases" "downloads.sxemacs.org"
+ "xemacs-pkgs/beta/experimental/packages" "http")))
("US Pre-Releases (Main XEmacs Site)" "ftp.xemacs.org"
- "pub/xemacs/beta/experimental/packages")
+ "pub/xemacs/beta/experimental/packages" "ftp")
;; In alphabetical order of Country, our mirrors...
- ("Argentina Pre-Releases (xmundo.net)" "xemacs.xmundo.net"
- "pub/mirrors/xemacs/beta/experimental/packages")
- ("Australia Pre-Releases (aarnet.edu.au)" "mirror.aarnet.edu.au"
- "pub/xemacs/beta/experimental/packages")
- ("Australia Pre-Releases (au.xemacs.org)" "ftp.au.xemacs.org"
- "pub/xemacs/beta/experimental/packages")
- ("Austria Pre-Releases (at.xemacs.org)" "ftp.at.xemacs.org"
- "editors/xemacs/beta/experimental/packages")
+ ;; Timing out
("Belgium Pre-Releases (be.xemacs.org)" "ftp.be.xemacs.org"
- "xemacs/beta/experimental/packages")
- ("Brazil Pre-Releases (br.xemacs.org)" "ftp.br.xemacs.org"
- "pub/xemacs/xemacs-21.5/experimental/packages")
+ "xemacs/beta/experimental/packages" "ftp")
("Canada Pre-Releases (ca.xemacs.org)" "ftp.ca.xemacs.org"
- "pub/Mirror/xemacs/beta/experimental/packages")
- ("Canada Pre-Releases (nrc.ca)" "ftp.nrc.ca"
- "pub/packages/editors/xemacs/beta/experimental/packages")
- ;; no anonymous ftp available, uncomment when updating website
- ;; with
- ;; xemacs-builds/adrian/website/package-get-2-download-sites.el
-; ("Chile Pre-Releases (cl.xemacs.org)" "ftp.cl.xemacs.org"
-; "beta/experimental/packages")
- ("China Pre-Releases (ftp.cn.xemacs.org)" "ftp.cn.xemacs.org"
- "pub/xemacs/beta/experimental/packages")
- ("Czech Republic Pre-Releases (cz.xemacs.org)" "ftp.cz.xemacs.org"
- "MIRRORS/ftp.xemacs.org/pub/xemacs/xemacs-21.5/experimental/packages")
+ "pub/Mirror/xemacs/beta/experimental/packages" "ftp")
("Denmark Pre-Releases (dk.xemacs.org)" "ftp.dk.xemacs.org"
- "xemacs/beta/experimental/packages")
- ("Finland Pre-Releases (fi.xemacs.org)" "ftp.fi.xemacs.org"
- "pub/mirrors/ftp.xemacs.org/pub/tux/xemacs/beta/experimental/packages")
+ "xemacs/beta/experimental/packages" "ftp")
("France Pre-Releases (fr.xemacs.org)" "ftp.fr.xemacs.org"
- "pub/xemacs/beta/experimental/packages")
+ "pub/xemacs/beta/experimental/packages" "ftp")
+ ; Was a month out of date as of 2013-04-12, hopefully not a sign
+ ; it is no longer updating.
("France Pre-Releases (mirror.cict.fr)" "mirror.cict.fr"
- "xemacs/beta/experimental/packages")
+ "xemacs/beta/experimental/packages" "ftp")
("France Pre-Releases (pasteur.fr)" "ftp.pasteur.fr"
- "pub/computing/xemacs/beta/experimental/packages")
+ "pub/computing/xemacs/beta/experimental/packages" "ftp")
+ ;; Very outdated, experimental not updated since 2013
("Germany Pre-Releases (de.xemacs.org)" "ftp.de.xemacs.org"
- "pub/ftp.xemacs.org/tux/xemacs/beta/experimental/packages")
+ "pub/ftp.xemacs.org/tux/xemacs/beta/experimental/packages" "ftp")
+ ;; Timing out
("Greece Pre-Releases (gr.xemacs.org)" "ftp.gr.xemacs.org"
- "mirrors/XEmacs/ftp/beta/experimental/packages")
- ("Hong Kong Pre-Releases (hk.xemacs.org)" "ftp.hk.xemacs.org"
- "pub/xemacsftp/beta/experimental/packages")
- ("Ireland Pre-Releases (ie.xemacs.org)" "ftp.ie.xemacs.org"
- "mirrors/ftp.xemacs.org/pub/xemacs/beta/experimental/packages")
+ "mirrors/XEmacs/ftp/beta/experimental/packages" "ftp")
("Ireland Pre-Releases (heanet.ie)" "ftp.heanet.ie"
- "mirrors/ftp.xemacs.org/beta/experimental/packages")
+ "mirrors/ftp.xemacs.org/beta/experimental/packages" "ftp")
+ ;; Timing out
("Italy Pre-Releases (it.xemacs.org)" "ftp.it.xemacs.org"
- "unix/packages/XEMACS/beta/experimental/packages")
+ "unix/packages/XEMACS/beta/experimental/packages" "ftp")
+ ; Was out of date as at 2013-04-12. Hopefully not a sign they are
+ ; no longer updating.
+ ;; Timing out
("Japan Pre-Releases (dti.ad.jp)" "ftp.dti.ad.jp"
- "pub/unix/editor/xemacs/beta/experimental/packages")
-; ("Japan Pre-Releases (jaist.ac.jp)" "ftp.jaist.ac.jp"
-; "pub/GNU/xemacs/beta/experimental/packages")
- ("Japan Pre-Releases (jp.xemacs.org)" "ftp.jp.xemacs.org"
- "pub/text/xemacs/beta/experimental/packages")
- ("Korea Pre-Releases (kr.xemacs.org)" "ftp.kr.xemacs.org"
- "pub/tools/emacs/xemacs/beta/experimental/packages")
- ("Netherlands Pre-Releases (nl.xemacs.org)" "ftp.nl.xemacs.org"
- "pub/xemacs/ftp/beta/experimental/packages")
- ;; no anonymous ftp available, uncomment when updating website
- ;; with
- ;; xemacs-builds/adrian/website/package-get-2-download-sites.el
-; ("Netherlands Pre-Releases (xemacsftp.digimirror.nl)" "xemacsftp.digimirror.nl"
-; "beta/experimental/packages")
+ "pub/unix/editor/xemacs/beta/experimental/packages" "ftp")
("Norway Pre-Releases (no.xemacs.org)" "ftp.no.xemacs.org"
- "pub/xemacs/beta/experimental/packages")
+ "pub/xemacs/beta/experimental/packages" "ftp")
("Portugal Pre-Releases (pt.xemacs.org)" "ftp.pt.xemacs.org"
- "pub/MIRRORS/ftp.xemacs.org/beta/experimental/packages")
- ("Russia Pre-Releases (ru.xemacs.org)" "ftp.ru.xemacs.org"
- "pub/emacs/xemacs/beta/experimental/packages")
+ "pub/MIRRORS/ftp.xemacs.org/beta/experimental/packages" "ftp")
("Saudi Arabia Pre-Releases (sa.xemacs.org)" "ftp.sa.xemacs.org"
- "pub/xemacs.org/beta/experimental/packages")
+ "pub/xemacs.org/beta/experimental/packages" "ftp")
("Sweden Pre-Releases (se.xemacs.org)" "ftp.se.xemacs.org"
- "pub/gnu/xemacs/beta/experimental/packages")
+ "pub/gnu/xemacs/beta/experimental/packages" "ftp")
("Switzerland Pre-Releases (ch.xemacs.org)" "ftp.ch.xemacs.org"
- "mirror/xemacs/beta/experimental/packages")
+ "mirror/xemacs/beta/experimental/packages" "ftp")
("Taiwan Pre-Releases (ftp.tw.xemacs.org)" "ftp.tw.xemacs.org"
- "Unix/Editors/XEmacs/beta/experimental/packages")
+ "Unix/Editors/XEmacs/beta/experimental/packages" "ftp")
("UK Pre-Releases (uk.xemacs.org)" "ftp.uk.xemacs.org"
- "sites/ftp.xemacs.org/pub/xemacs/beta/experimental/packages")
+ "sites/ftp.xemacs.org/pub/xemacs/beta/experimental/packages" "ftp")
("US Pre-Releases (ibiblio.org)" "mirrors.ibiblio.org"
- "pub/mirrors/xemacs/beta/experimental/packages")
- ("US Pre-Releases (us.xemacs.org)" "ftp.us.xemacs.org"
- "pub/mirrors/xemacs/beta/experimental/packages")
+ "pub/mirrors/xemacs/beta/experimental/packages" "ftp")
)
"*List of remote sites available for downloading \"Pre-Release\" packages.
-List format is '(site-description site-name directory-on-site).
-SITE-DESCRIPTION is a textual description of the site. SITE-NAME
-is the internet address of the download site. DIRECTORY-ON-SITE
-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."
+
+List format is '(site-description site-name directory-on-site url-scheme).
+SITE-DESCRIPTION is a textual description of the site. SITE-NAME is
+the internet address of the download site. DIRECTORY-ON-SITE is the
+directory on the site in which packages may be found. URL-SCHEME is
+the protocol such as `http', `ftp', etc. This variable is used to
+initialize `package-get-remote', the variable actually used to specify
+package download sites."
:tag "Pre-Release Package download sites"
- :type '(repeat (list (string :tag "Name") host-name directory))
+ :type '(repeat (list (string :tag "Name")
+ host-name directory url-scheme))
:group 'package-get)
;;;###autoload
-(defcustom package-get-site-release-download-sites
- nil
+(defcustom package-get-site-release-download-sites nil
"*List of remote sites available for downloading \"Site Release\" packages.
-List format is '(site-description site-name directory-on-site).
-SITE-DESCRIPTION is a textual description of the site. SITE-NAME
-is the internet address of the download site. DIRECTORY-ON-SITE
-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."
+
+List format is '(site-description site-name directory-on-site url-scheme).
+SITE-DESCRIPTION is a textual description of the site. SITE-NAME is
+the internet address of the download site. DIRECTORY-ON-SITE is the
+directory on the site in which packages may be found. URL-SCHEME is
+the protocol such as `http', `ftp', etc. This variable is used to
+initialize `package-get-remote', the variable actually used to specify
+package download sites."
:tag "Site Release Package download sites"
- :type '(repeat (list (string :tag "Name") host-name directory))
+ :type '(repeat (list (string :tag "Name")
+ host-name directory url-scheme))
:group 'package-get)
(defcustom package-get-remove-copy t
"Update an entry in `package-get-base'."
(let ((existing (assq (car entry) package-get-base)))
(if existing
- (setcdr existing (cdr entry))
+ (setcdr existing (cdr entry))
(setq package-get-base (cons entry package-get-base)))))
(defun package-get-locate-file (file &optional nil-if-not-found no-remote)
(if (file-name-absolute-p file)
file
(let ((site package-get-remote)
- (expanded nil))
+ (expanded nil))
(when site
(unless (and no-remote (caar (list site)))
(let ((expn (package-get-remote-filename (car (list site)) file)))
(setq site nil
expanded expn)))))
(or expanded
- (and (not nil-if-not-found)
- file)))))
+ (and (not nil-if-not-found)
+ file)))))
(defun package-get-locate-index-file (no-remote)
- "Locate the package-get index file.
+ "Locate the package-get index file.
Do not return remote paths if NO-REMOTE is non-nil. If the index
file doesn't exist in `package-get-package-index-file-location', ask
package-get-package-index-file-location))
(progn
(save-excursion
- (set-buffer
+ (set-buffer
(find-file-noselect (expand-file-name
package-get-base-filename
package-get-package-index-file-location)))
(md5 (current-buffer)))))
(when (not (file-writable-p location))
(if (y-or-n-p (format "Sorry, %s is read-only, can I use %s? "
- location user-init-directory))
+ location user-packages-topdir))
(setq location (expand-file-name
package-get-base-filename
package-get-package-index-file-location))
(interactive
(let ((dflt (package-get-locate-index-file nil)))
(list (read-file-name "Load package-get database: "
- (file-name-directory dflt)
- dflt
- t
- (file-name-nondirectory dflt)))))
+ (file-name-directory dflt)
+ dflt
+ t
+ (file-name-nondirectory dflt)))))
(setq db-file (expand-file-name (or db-file
- (package-get-locate-index-file
- (not force-current)))))
+ (package-get-locate-index-file
+ (not force-current)))))
(if (not (file-exists-p db-file))
(error 'file-error
(format "Package-get database file `%s' does not exist" db-file)))
(format "Package-get database file `%s' not readable" db-file)))
(let ((buf (get-buffer-create "*package database*")))
(unwind-protect
- (save-excursion
- (set-buffer buf)
- (erase-buffer buf)
- (insert-file-contents-literally db-file)
- (package-get-update-base-from-buffer buf)
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer buf)
+ (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)))
(kill-buffer buf))))
(save-excursion
(goto-char start)
(if (not (re-search-forward "^(package-get-update-base-entry" nil t))
- (error 'search-failed
+ (error 'search-failed
"Buffer does not contain package-get database entries"))
(beginning-of-line)
(let ((count 0))
(while (and (< (point) end)
- (re-search-forward "^(package-get-update-base-entry" nil t))
- (beginning-of-line)
- (let ((entry (read (current-buffer))))
- (if (or (not (consp entry))
- (not (eq (car entry) 'package-get-update-base-entry)))
- (error 'syntax-error
+ (re-search-forward "^(package-get-update-base-entry" nil t))
+ (beginning-of-line)
+ (let ((entry (read (current-buffer))))
+ (if (or (not (consp entry))
+ (not (eq (car entry) 'package-get-update-base-entry)))
+ (error 'syntax-error
"Invalid package-get database entry found"))
- (package-get-update-base-entry
- (car (cdr (car (cdr entry)))))
- (setq count (1+ count))))
+ (package-get-update-base-entry
+ (car (cdr (car (cdr entry)))))
+ (setq count (1+ count))))
(message "Got %d package-get database entries" count))))
;;;###autoload
(package-get-require-base t)
(let ((buf (get-buffer-create "*package database*")))
(unwind-protect
- (save-excursion
- (set-buffer buf)
- (erase-buffer buf)
- (goto-char (point-min))
- (let ((entries package-get-base) entry plist)
- (insert ";; Package Index file -- Do not edit manually.\n")
- (insert ";;;@@@\n")
- (while entries
- (setq entry (car entries))
- (setq plist (car (cdr entry)))
- (insert "(package-get-update-base-entry (quote\n")
- (insert (format "(%s\n" (symbol-name (car entry))))
- (while plist
- (insert (format " %s%s %S\n"
- (if (eq plist (car (cdr entry))) "(" " ")
- (symbol-name (car plist))
- (car (cdr plist))))
- (setq plist (cdr (cdr plist))))
- (insert "))\n))\n;;;@@@\n")
- (setq entries (cdr entries))))
- (insert ";; Package Index file ends here\n")
- (write-region (point-min) (point-max) file))
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer buf)
+ (goto-char (point-min))
+ (let ((entries package-get-base) entry plist)
+ (insert ";; Package Index file -- Do not edit manually.\n")
+ (insert ";;;@@@\n")
+ (while entries
+ (setq entry (car entries))
+ (setq plist (car (cdr entry)))
+ (insert "(package-get-update-base-entry (quote\n")
+ (insert (format "(%s\n" (symbol-name (car entry))))
+ (while plist
+ (insert (format " %s%s %S\n"
+ (if (eq plist (car (cdr entry))) "(" " ")
+ (symbol-name (car plist))
+ (car (cdr plist))))
+ (setq plist (cdr (cdr plist))))
+ (insert "))\n))\n;;;@@@\n")
+ (setq entries (cdr entries))))
+ (insert ";; Package Index file ends here\n")
+ (write-region (point-min) (point-max) file))
(kill-buffer buf))))
(defun package-get-interactive-package-query (get-version package-symbol)
(if (not (setq fetched-packages
(package-get-all reqd-name reqd-version
fetched-packages
- install-dir)))
+ install-dir)))
(throw 'exit nil))))
(setq this-requires (cdr this-requires))))
fetched-packages))
required by PACKAGES."
(package-get-require-base t)
(let ((orig-packages packages)
- dependencies provided)
+ dependencies provided)
(while packages
(let* ((package (car packages))
- (the-package (package-get-info-find-package
- package-get-base package))
- (this-package (package-get-info-version
- the-package nil))
- (this-requires (package-get-info-prop this-package 'requires))
- (new-depends (set-difference
- (mapcar
- #'(lambda (reqd)
- (let* ((reqd-package (package-get-package-provider reqd))
- (reqd-name (car reqd-package)))
- (if (null reqd-name)
- (error 'search-failed
+ (the-package (package-get-info-find-package
+ package-get-base package))
+ (this-package (package-get-info-version
+ the-package nil))
+ (this-requires (package-get-info-prop this-package 'requires))
+ (new-depends (set-difference
+ (mapcar
+ #'(lambda (reqd)
+ (let* ((reqd-package (package-get-package-provider reqd))
+ (reqd-name (car reqd-package)))
+ (if (null reqd-name)
+ (error 'search-failed
(format "Unable to find a provider for %s" reqd)))
- reqd-name))
- this-requires)
- dependencies))
- (this-provides (package-get-info-prop this-package 'provides)))
- (setq dependencies
- (union dependencies new-depends))
- (setq provided
- (union provided (union (list package) this-provides)))
- (setq packages
- (union new-depends (cdr packages)))))
+ reqd-name))
+ this-requires)
+ dependencies))
+ (this-provides (package-get-info-prop this-package 'provides)))
+ (setq dependencies
+ (union dependencies new-depends))
+ (setq provided
+ (union provided (union (list package) this-provides)))
+ (setq packages
+ (union new-depends (cdr packages)))))
(set-difference dependencies orig-packages)))
(defun package-get-load-package-file (lispdir file)
(when (memq item (package-get-info (caar pkgs) field))
(setq results (push (caar pkgs) results)))
(setq pkgs (cdr pkgs)))))
- (t
+ (t
(error 'wrong-type-argument field)))
(if (interactive-p)
(if arg
(package-get-info-version
(package-get-info-find-package package-get-base
package) version))
- (latest (package-get-info-prop this-package 'version))
- (installed (package-get-key package :version))
+ (latest (package-get-info-prop this-package 'version))
+ (installed (package-get-key package :version))
(found nil)
+ (host nil)
(search-dir package-get-remote)
(base-filename (package-get-info-prop this-package 'filename))
(package-status t)
filenames full-package-filename)
(if (and (equal (package-get-info package 'category) "mule")
(not (featurep 'mule)))
- (error 'invalid-state
+ (error 'invalid-state
"Mule packages can't be installed with a non-Mule SXEmacs"))
(if (null this-package)
(if package-get-remote
;; If they asked for the latest using version=nil, don't get an older
;; version than we already have.
(if installed
- (if (> (if (stringp installed)
- (string-to-number installed)
- installed)
- (if (stringp latest)
- (string-to-number latest)
- latest))
- (if (not (null version))
- (warn "Installing %s package version %s, you had a newer version %s"
+ (if (> (if (stringp installed)
+ (string-to-number installed)
+ installed)
+ (if (stringp latest)
+ (string-to-number latest)
+ latest))
+ (if (not (null version))
+ (warn "Installing %s package version %s, you had a newer version %s"
package latest installed)
- (warn "Skipping %s package, you have a newer version %s"
+ (warn "Skipping %s package, you have a newer version %s"
package installed)
- (throw 'skip-update t))))
+ (throw 'skip-update t))))
;; Contrive a list of possible package filenames.
;; Ugly. Is there a better way to do this?
;; and copy it into the staging directory. Then validate
;; the checksum. Finally, install the package.
(catch 'done
- (let (search-filenames host dir current-filename dest-filename)
+ (let (search-filenames dir current-filename dest-filename)
;; In each search directory ...
(when search-dir
(setq host (car search-dir)
(package-get-info package 'size)))
(setq full-package-filename dest-filename))
+ ;; Using EFS
;; If the file exists on the remote system ...
- ((file-exists-p (package-get-remote-filename
- search-dir current-filename))
+ ((and (not package-get-have-curl)
+ (file-exists-p (package-get-remote-filename
+ search-dir current-filename)))
;; Get it
(setq full-package-filename dest-filename)
(message "Retrieving package `%s' ..."
(sit-for 0)
(copy-file (package-get-remote-filename search-dir
current-filename)
- full-package-filename t)))
+ full-package-filename t))
+
+ ;; Using ffi-curl
+ (package-get-have-curl
+ (setq full-package-filename dest-filename)
+ (message "Retrieving package `%s' ..." current-filename)
+ (declare-fboundp
+ (curl:download (package-get-remote-filename search-dir
+ current-filename)
+ full-package-filename))))
;; If we found it, we're done.
(if (and full-package-filename
(package-get-info-prop this-package
'md5sum)))
(progn
- (delete-file full-package-filename)
+ (unless (null host)
+ (delete-file full-package-filename))
(error 'process-error
(format "Package %s does not match md5 checksum %s has been deleted"
base-filename full-package-filename)))))
(message "Installation of package %s failed." base-filename)
(sit-for 0)
(switch-to-buffer package-admin-temp-buffer)
- (delete-file full-package-filename)
+ ;; null host means a local package mirror
+ (unless (null host)
+ (delete-file full-package-filename))
(setq package-status nil)))
(setq found t))
- (if (and found package-get-remove-copy)
+ (if (and found package-get-remove-copy (not (null host)))
(delete-file full-package-filename))
package-status)))
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
+words:
+
site-name:remote-directory/filename.
-If (car search) is nil, (cadr search is interpreted as a local directory).
-"
+If ffi-curl has been loaded then this will return a URL style name,
+for example:
+
+ http://site-name/remote-directory/filename
+
+The url scheme to use in this case is from (third search).
+
+If (car search) is nil, (cadr search is interpreted as a local
+directory)."
(if (file-remote-p filename)
filename
- (let ((dir (cadr search)))
- (concat (when (car search)
- (concat
- (if (string-match "@" (car search))
- "/"
- "/anonymous@")
- (car search) ":"))
- (if (string-match "/$" dir)
- dir
- (concat dir "/"))
- filename))))
+ (let ((site (car search))
+ (dir (cadr search))
+ (scheme (third search)))
+ (if (and site package-get-have-curl)
+ (concat scheme "://" site "/" dir "/" filename)
+ (concat (when site
+ (concat
+ (if (string-match "@" site)
+ "/"
+ "/anonymous@")
+ site ":"))
+ (if (string-match "/$" dir)
+ dir
+ (concat dir "/"))
+ filename)))))
(defun package-get-installedp (package version)
"Determine if PACKAGE with VERSION has already been installed.
(setq packages (cdr packages)))
(when (interactive-p)
(if found
- (message "%S" found)
- (message "No appropriate package found")))
+ (message "%S" found)
+ (message "No appropriate package found")))
found))
(defun package-get-ever-installed-p (pkg &optional notused)
(intern (substring (symbol-name pkg) 0 (match-beginning 0))))
t)))
-;;; FIXME: see comment at end of `pui-bootstrap'
-
-;;;###autoload
-(defun pui-bootstrap ()
- "Bootstrap the SXEmacs Package Tools.
-
-The Package Tools, under normal circumstances, cannot work until a
-couple of packages are pre-installed by hand. This function eliminates
-the need to do that. It uses FFI and libcurl to download and install
-the lastest package index file, the EFS and xemacs-base packages.
-
-Obviously you can't use this if you didn't enable FFI support in your
-SXEmacs or if you don't have libffi on your system.
-
-This isn't designed to replace the existing Package Tools so after
-you have run `pui-bootstrap' once you should then use the normal PUI
-tools, `pui-list-packages' etc."
- (interactive)
- ;; A little sanity checking never hurt anybody
- (when (featurep '(and efs-autoloads xemacs-base-autoloads))
- (error 'invalid-operation "PUI doesn't need bootstrapping"))
- (when (and (fboundp 'ffi-defun)
- (not (featurep '(and ffi ffi-curl))))
- (require 'ffi-curl))
- (unless (featurep 'ffi)
- (error 'unimplemented "FFI"))
- ;; One last check... has `package-get-remote' been set?
- (if (not (cdr package-get-remote))
- (when (y-or-n-p "You haven't set a download site, do you need help ")
- (declare-fboundp (Info-goto-node "(sxemacs)Bootstrapping PUI")))
- ;; We should be good to go
- (let* ((site (car package-get-remote))
- (dir (cadr package-get-remote))
- (url (concat "ftp://" site "/" dir "/"))
- (dldir (temp-directory))
- (index (expand-file-name package-get-base-filename
- package-get-package-index-file-location))
- xemacs-base-pkg
- efs-pkg
- ;status)
- )
- ;; Grab the index
- (message "Retrieving index, please be patient")
- (declare-fboundp (curl:download (concat url package-get-base-filename) index))
- (message "Retrieving index, done!")
- ;; Update the db
- (set-buffer (find-file-noselect index))
- (package-get-update-base-from-buffer)
- (kill-buffer (current-buffer))
- ;; Get xemacs-base, EFS
- (setq xemacs-base-pkg (package-get-info 'xemacs-base 'filename))
- (setq efs-pkg (package-get-info 'efs 'filename))
- (message "Retrieving %s, please be patient" xemacs-base-pkg)
- (declare-fboundp (curl:download (concat url xemacs-base-pkg)
- (expand-file-name xemacs-base-pkg dldir)))
- (message "Retrieving %s, please be patient" efs-pkg)
- (declare-fboundp (curl:download (concat url efs-pkg)
- (expand-file-name efs-pkg dldir)))
- (message "Download complete.")
- ;; Install xemacs-base
- (if (equal (package-get-info 'xemacs-base 'md5sum)
- (with-temp-buffer
- (insert-file-contents-literally
- (expand-file-name xemacs-base-pkg dldir))
- (md5 (current-buffer))))
- (progn
- (package-admin-add-binary-package
- (expand-file-name xemacs-base-pkg dldir)
- (package-admin-get-install-dir 'xemacs-base))
- (push (file-name-as-directory
- (expand-file-name "lisp/xemacs-base"
- (package-admin-get-install-dir 'xemacs-base)))
- load-path)
- (load-file (expand-file-name "lisp/xemacs-base/_pkg.el"
- (package-admin-get-install-dir 'xemacs-base)))
- (load-file (expand-file-name "lisp/xemacs-base/auto-autoloads.el"
- (package-admin-get-install-dir 'xemacs-base)))
- (message "xemacs-base package installed"))
- (delete-file (expand-file-name xemacs-base-pkg dldir))
- (error "MD5 mismatch, %s deleted" (expand-file-name xemacs-base-pkg dldir)))
- ;; Install EFS
- (if (equal (package-get-info 'efs 'md5sum)
- (with-temp-buffer
- (insert-file-contents-literally
- (expand-file-name efs-pkg dldir))
- (md5 (current-buffer))))
- (progn
- (package-admin-add-binary-package
- (expand-file-name efs-pkg dldir)
- (package-admin-get-install-dir 'efs))
- (push (file-name-as-directory
- (expand-file-name "lisp/efs"
- (package-admin-get-install-dir 'efs)))
- load-path)
- (load-file (expand-file-name "lisp/efs/_pkg.el"
- (package-admin-get-install-dir 'efs)))
- (load-file (expand-file-name "lisp/efs/auto-autoloads.el"
- (package-admin-get-install-dir 'efs)))
- (message "efs package installed"))
- (delete-file (expand-file-name efs-pkg dldir))
- (error "MD5 mismatch, %s deleted" (expand-file-name efs-pkg dldir)))
- (when (y-or-n-p "Install more packages? ")
- (declare-fboundp (pui-list-packages))))))
-
(provide 'package-get)
;; On-load forms
(require 'package-ui)
(load "cl-macs"))
+;;;###autoload (condition-case nil (require 'ffi-curl) (error nil))
+
;;; package-get.el ends here
projects / sxemacs / blobdiff