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 2017-01-22 17:55:59 -05:00
parent 1846984bd0
commit 65fea08de3
2 changed files with 119 additions and 43 deletions

View file

@ -307,6 +307,20 @@ cache folder.")
(configuration-layer/load-or-install-protected-package 'package-build) (configuration-layer/load-or-install-protected-package 'package-build)
(configuration-layer/load-or-install-protected-package 'quelpa)) (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) (defun configuration-layer//resolve-package-archives (archives)
"Resolve HTTP handlers for each archive in ARCHIVES and return a list "Resolve HTTP handlers for each archive in ARCHIVES and return a list
of all reachable ones. of all reachable ones.
@ -315,11 +329,11 @@ left untouched.
The returned list has a `package-archives' compliant format." The returned list has a `package-archives' compliant format."
(mapcar (mapcar
(lambda (x) (lambda (x)
(cons (car x) (let ((aname (car x))
(if (or (string-match-p "http" (cdr x)) (apath (cdr x)))
(string-prefix-p "~" (cdr x)) (cons aname
(string-prefix-p "/" (cdr x))) (if (configuration-layer//package-archive-absolute-pathp x)
(cdr x) apath
(concat (concat
(if (and dotspacemacs-elpa-https (if (and dotspacemacs-elpa-https
(not spacemacs-insecure) (not spacemacs-insecure)
@ -327,11 +341,11 @@ The returned list has a `package-archives' compliant format."
;; not support HTTPS ;; not support HTTPS
;; TODO when org ELPA repo support ;; TODO when org ELPA repo support
;; HTTPS remove the check ;; HTTPS remove the check
;; `(not (equal "org" (car x)))' ;; `(not (equal "org" aname))'
(not (equal "org" (car x)))) (not (equal "org" aname)))
"https://" "https://"
"http://") "http://")
(cdr x))))) apath)))))
archives)) archives))
(defun configuration-layer/retrieve-package-archives (&optional quiet force) (defun configuration-layer/retrieve-package-archives (&optional quiet force)
@ -355,13 +369,18 @@ refreshed during the current session."
(let ((count (length package-archives)) (let ((count (length package-archives))
(i 1)) (i 1))
(dolist (archive package-archives) (dolist (archive package-archives)
(let ((aname (car archive))
(apath (cdr archive)))
(unless quiet (unless quiet
(spacemacs-buffer/replace-last-line (spacemacs-buffer/replace-last-line
(format "--> refreshing package archive: %s... [%s/%s]" (format "--> refreshing package archive: %s... [%s/%s]"
(car archive) i count) t)) aname i count) t))
(spacemacs//redisplay) (spacemacs//redisplay)
(setq i (1+ i)) (setq i (1+ i))
(unless (eq 'error (unless
(and (not (configuration-layer//package-archive-local-pathp
archive))
(eq 'error
(with-timeout (with-timeout
(dotspacemacs-elpa-timeout (dotspacemacs-elpa-timeout
(progn (progn
@ -369,18 +388,19 @@ refreshed during the current session."
'spacemacs 'spacemacs
(format (format
"\nError connection time out for %s repository!" "\nError connection time out for %s repository!"
(car archive)) :warning) aname) :warning)
'error)) 'error))
(condition-case err (condition-case err
(url-retrieve-synchronously (cdr archive)) (url-retrieve-synchronously apath)
('error ('error
(display-warning 'spacemacs (display-warning
'spacemacs
(format (format
"\nError while contacting %s repository!" "\nError while contacting %s repository!"
(car archive)) :warning) aname) :warning)
'error)))) 'error)))))
(let ((package-archives (list archive))) (let ((package-archives (list archive)))
(package-refresh-contents)))) (package-refresh-contents)))))
(package-read-all-archive-contents) (package-read-all-archive-contents)
(unless quiet (spacemacs-buffer/append "\n"))))) (unless quiet (spacemacs-buffer/append "\n")))))

View file

@ -217,6 +217,62 @@
(helper--set-layers `(,(cfgl-layer "layer2" :name 'layer2)) t) (helper--set-layers `(,(cfgl-layer "layer2" :name 'layer2)) t)
(should (eq 'layer2 (cfgl-package-get-safe-owner pkg))))) (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 ;; configuration-layer//resolve-package-archives
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------