core: add support for local elpa repositories
It is now possible to add local elpa repositories to private variable
configuration-layer--elpa-archives for instance:
(defvar configuration-layer--elpa-archives
'(("spacelpa" . "~/.emacs.d/.cache/spacelpa/"))
"List of ELPA archives required by Spacemacs.")
New functions:
- configuration-layer//package-archive-absolute-pathp
- configuration-layer//package-archive-local-pathp
This commit is contained in:
syl20bnr
parent
1846984bd0
commit
65fea08de3
|
|
@ -307,6 +307,20 @@ cache folder.")
|
|||
(configuration-layer/load-or-install-protected-package 'package-build)
|
||||
(configuration-layer/load-or-install-protected-package 'quelpa))
|
||||
|
||||
(defun configuration-layer//package-archive-absolute-pathp (archive)
|
||||
"Return t if ARCHIVE has an absolute path defined."
|
||||
(let ((path (cdr archive)))
|
||||
(or (string-match-p "http" path)
|
||||
(string-prefix-p "~" path)
|
||||
(string-prefix-p "/" path))))
|
||||
|
||||
(defun configuration-layer//package-archive-local-pathp (archive)
|
||||
"Return t if ARCHIVE has a local path."
|
||||
(let ((path (cdr archive)))
|
||||
(or (string-prefix-p "~" path)
|
||||
(string-prefix-p "/" path)
|
||||
(string-prefix-p "\." path))))
|
||||
|
||||
(defun configuration-layer//resolve-package-archives (archives)
|
||||
"Resolve HTTP handlers for each archive in ARCHIVES and return a list
|
||||
of all reachable ones.
|
||||
|
|
@ -315,23 +329,23 @@ left untouched.
|
|||
The returned list has a `package-archives' compliant format."
|
||||
(mapcar
|
||||
(lambda (x)
|
||||
(cons (car x)
|
||||
(if (or (string-match-p "http" (cdr x))
|
||||
(string-prefix-p "~" (cdr x))
|
||||
(string-prefix-p "/" (cdr x)))
|
||||
(cdr x)
|
||||
(concat
|
||||
(if (and dotspacemacs-elpa-https
|
||||
(not spacemacs-insecure)
|
||||
;; for now org ELPA repository does
|
||||
;; not support HTTPS
|
||||
;; TODO when org ELPA repo support
|
||||
;; HTTPS remove the check
|
||||
;; `(not (equal "org" (car x)))'
|
||||
(not (equal "org" (car x))))
|
||||
"https://"
|
||||
"http://")
|
||||
(cdr x)))))
|
||||
(let ((aname (car x))
|
||||
(apath (cdr x)))
|
||||
(cons aname
|
||||
(if (configuration-layer//package-archive-absolute-pathp x)
|
||||
apath
|
||||
(concat
|
||||
(if (and dotspacemacs-elpa-https
|
||||
(not spacemacs-insecure)
|
||||
;; for now org ELPA repository does
|
||||
;; not support HTTPS
|
||||
;; TODO when org ELPA repo support
|
||||
;; HTTPS remove the check
|
||||
;; `(not (equal "org" aname))'
|
||||
(not (equal "org" aname)))
|
||||
"https://"
|
||||
"http://")
|
||||
apath)))))
|
||||
archives))
|
||||
|
||||
(defun configuration-layer/retrieve-package-archives (&optional quiet force)
|
||||
|
|
@ -355,32 +369,38 @@ refreshed during the current session."
|
|||
(let ((count (length package-archives))
|
||||
(i 1))
|
||||
(dolist (archive package-archives)
|
||||
(unless quiet
|
||||
(spacemacs-buffer/replace-last-line
|
||||
(format "--> refreshing package archive: %s... [%s/%s]"
|
||||
(car archive) i count) t))
|
||||
(spacemacs//redisplay)
|
||||
(setq i (1+ i))
|
||||
(unless (eq 'error
|
||||
(with-timeout
|
||||
(dotspacemacs-elpa-timeout
|
||||
(progn
|
||||
(display-warning
|
||||
'spacemacs
|
||||
(format
|
||||
"\nError connection time out for %s repository!"
|
||||
(car archive)) :warning)
|
||||
'error))
|
||||
(condition-case err
|
||||
(url-retrieve-synchronously (cdr archive))
|
||||
('error
|
||||
(display-warning 'spacemacs
|
||||
(format
|
||||
"\nError while contacting %s repository!"
|
||||
(car archive)) :warning)
|
||||
'error))))
|
||||
(let ((package-archives (list archive)))
|
||||
(package-refresh-contents))))
|
||||
(let ((aname (car archive))
|
||||
(apath (cdr archive)))
|
||||
(unless quiet
|
||||
(spacemacs-buffer/replace-last-line
|
||||
(format "--> refreshing package archive: %s... [%s/%s]"
|
||||
aname i count) t))
|
||||
(spacemacs//redisplay)
|
||||
(setq i (1+ i))
|
||||
(unless
|
||||
(and (not (configuration-layer//package-archive-local-pathp
|
||||
archive))
|
||||
(eq 'error
|
||||
(with-timeout
|
||||
(dotspacemacs-elpa-timeout
|
||||
(progn
|
||||
(display-warning
|
||||
'spacemacs
|
||||
(format
|
||||
"\nError connection time out for %s repository!"
|
||||
aname) :warning)
|
||||
'error))
|
||||
(condition-case err
|
||||
(url-retrieve-synchronously apath)
|
||||
('error
|
||||
(display-warning
|
||||
'spacemacs
|
||||
(format
|
||||
"\nError while contacting %s repository!"
|
||||
aname) :warning)
|
||||
'error)))))
|
||||
(let ((package-archives (list archive)))
|
||||
(package-refresh-contents)))))
|
||||
(package-read-all-archive-contents)
|
||||
(unless quiet (spacemacs-buffer/append "\n")))))
|
||||
|
||||
|
|
|
|||
|
|
@ -217,6 +217,62 @@
|
|||
(helper--set-layers `(,(cfgl-layer "layer2" :name 'layer2)) t)
|
||||
(should (eq 'layer2 (cfgl-package-get-safe-owner pkg)))))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; configuration-layer//package-archive-absolute-pathp
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
(ert-deftest test-package-archive-absolute-pathp--http-absolute-path ()
|
||||
(let ((input '("melpa" . "http://melpa.org/packages/")))
|
||||
(should (configuration-layer//package-archive-absolute-pathp input))))
|
||||
|
||||
(ert-deftest test-package-archive-absolute-pathp--https-absolute-path ()
|
||||
(let ((input '("melpa" . "https://melpa.org/packages/")))
|
||||
(should (configuration-layer//package-archive-absolute-pathp input))))
|
||||
|
||||
(ert-deftest test-package-archive-absolute-pathp--user-home-tilde-absolute-path ()
|
||||
(let ((input '("spacelpa" . "~/.elpa/spacelpa")))
|
||||
(should (configuration-layer//package-archive-absolute-pathp input))))
|
||||
|
||||
(ert-deftest test-package-archive-absolute-pathp--user-home-slash-absolute-path ()
|
||||
(let ((input '("spacelpa" . "/home/rms/.elpa/spacelpa")))
|
||||
(should (configuration-layer//package-archive-absolute-pathp input))))
|
||||
|
||||
(ert-deftest test-package-archive-absolute-pathp--relative-path-local ()
|
||||
(let ((input '("melpa" . "../.elpa/spacelpa")))
|
||||
(should (not (configuration-layer//package-archive-absolute-pathp input)))))
|
||||
|
||||
(ert-deftest test-package-archive-absolute-pathp--not-absolute-path-remote ()
|
||||
(let ((input '("melpa" . "melpa.org/spacelpa")))
|
||||
(should (not (configuration-layer//package-archive-absolute-pathp input)))))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; configuration-layer//package-archive-local-pathp
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
(ert-deftest test-package-archive-local-pathp--http-not-local-path ()
|
||||
(let ((input '("melpa" . "http://melpa.org/packages/")))
|
||||
(should (not (configuration-layer//package-archive-local-pathp input)))))
|
||||
|
||||
(ert-deftest test-package-archive-local-pathp--https-not-local-path ()
|
||||
(let ((input '("melpa" . "https://melpa.org/packages/")))
|
||||
(should (not (configuration-layer//package-archive-local-pathp input)))))
|
||||
|
||||
(ert-deftest test-package-archive-local-pathp--user-home-tilde-local-path ()
|
||||
(let ((input '("spacelpa" . "~/.elpa/spacelpa")))
|
||||
(should (configuration-layer//package-archive-local-pathp input))))
|
||||
|
||||
(ert-deftest test-package-archive-local-pathp--user-home-slash-local-path ()
|
||||
(let ((input '("spacelpa" . "/home/rms/.elpa/spacelpa")))
|
||||
(should (configuration-layer//package-archive-local-pathp input))))
|
||||
|
||||
(ert-deftest test-package-archive-local-pathp--relative-local-path-local ()
|
||||
(let ((input '("melpa" . "../.elpa/spacelpa")))
|
||||
(should (configuration-layer//package-archive-local-pathp input))))
|
||||
|
||||
(ert-deftest test-package-archive-local-pathp--default-not-local-path-remote ()
|
||||
(let ((input '("melpa" . "melpa.org/spacelpa")))
|
||||
(should (not (configuration-layer//package-archive-local-pathp input)))))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; configuration-layer//resolve-package-archives
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
|
|
|||
Loading…
Reference in New Issue