diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/download.scm | 3 | ||||
| -rw-r--r-- | guix/git-download.scm | 2 | ||||
| -rw-r--r-- | guix/git.scm | 40 | ||||
| -rw-r--r-- | guix/glob.scm | 124 | ||||
| -rw-r--r-- | guix/import/elpa.scm | 25 |
5 files changed, 127 insertions, 67 deletions
diff --git a/guix/download.scm b/guix/download.scm index 50aa78fe0d..a91d924af8 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -66,7 +66,6 @@ "ftp://gcc.gnu.org/pub/gcc/" ,@(map (cut string-append <> "/gcc") gnu-mirrors)) (gnupg - "http://gd.tuwien.ac.at/privacy/gnupg/" "http://artfiles.org/gnupg.org" "http://www.crysys.hu/" "https://gnupg.org/ftp/gcrypt/" @@ -143,7 +142,6 @@ "http://apache.belnet.be/" "http://mirrors.ircam.fr/pub/apache/" "http://apache-mirror.rbc.ru/pub/apache/" - "ftp://gd.tuwien.ac.at/pub/infosys/servers/http/apache/dist/" ;; As a last resort, try the archive. "http://archive.apache.org/dist/") @@ -163,7 +161,6 @@ "ftp://ftp.piotrkosoft.net/pub/mirrors/ftp.x.org/" "ftp://ftp.portal-to-web.de/pub/mirrors/x.org/" "ftp://ftp.solnet.ch/mirror/x.org/" - "ftp://gd.tuwien.ac.at/X11/" "ftp://mi.mirror.garr.it/mirrors/x.org/" "ftp://mirror.cict.fr/x.org/" "ftp://mirror.switch.ch/mirror/X11/" diff --git a/guix/git-download.scm b/guix/git-download.scm index 731e549b38..33f102bc6c 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -109,7 +109,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ;; grep, etc. to be in $PATH. (set-path-environment-variable "PATH" '("bin") (match '#+inputs - (((names dirs) ...) + (((names dirs outputs ...) ...) dirs))) (or (git-fetch (getenv "git url") (getenv "git commit") diff --git a/guix/git.scm b/guix/git.scm index fc41e2ace3..d31c35f64f 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +28,8 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:export (%repository-cache-directory latest-repository-commit)) @@ -94,17 +97,32 @@ create the store directory name." (define (switch-to-ref repository ref) "Switch to REPOSITORY's branch, commit or tag specified by REF." - (let* ((oid (match ref - (('branch . branch) - (reference-target - (branch-lookup repository branch BRANCH-REMOTE))) - (('commit . commit) - (string->oid commit)) - (('tag . tag) - (reference-name->oid repository - (string-append "refs/tags/" tag))))) - (obj (object-lookup repository oid))) - (reset repository obj RESET_HARD))) + (define obj + (match ref + (('branch . branch) + (let ((oid (reference-target + (branch-lookup repository branch BRANCH-REMOTE)))) + (object-lookup repository oid))) + (('commit . commit) + (let ((len (string-length commit))) + ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we + ;; can't be sure it's available. Furthermore, 'string->oid' used to + ;; read out-of-bounds when passed a string shorter than 40 chars, + ;; which is why we delay calls to it below. + (if (< len 40) + (if (module-defined? (resolve-interface '(git object)) + 'object-lookup-prefix) + (object-lookup-prefix repository (string->oid commit) len) + (raise (condition + (&message + (message "long Git object ID is required"))))) + (object-lookup repository (string->oid commit))))) + (('tag . tag) + (let ((oid (reference-name->oid repository + (string-append "refs/tags/" tag)))) + (object-lookup repository oid))))) + + (reset repository obj RESET_HARD)) (define* (latest-repository-commit store url #:key diff --git a/guix/glob.scm b/guix/glob.scm index 4fc5173ac0..a9fc744802 100644 --- a/guix/glob.scm +++ b/guix/glob.scm @@ -18,80 +18,120 @@ (define-module (guix glob) #:use-module (ice-9 match) - #:export (compile-glob-pattern + #:export (string->sglob + compile-sglob + string->compiled-sglob glob-match?)) ;;; Commentary: ;;; ;;; This is a minimal implementation of "glob patterns" (info "(libc) ;;; Globbbing"). It is currently limited to simple patterns and does not -;;; support braces and square brackets, for instance. +;;; support braces, for instance. ;;; ;;; Code: -(define (wildcard-indices str) - "Return the list of indices in STR where wildcards can be found." - (let loop ((index 0) - (result '())) - (if (= index (string-length str)) - (reverse result) - (loop (+ 1 index) - (case (string-ref str index) - ((#\? #\*) (cons index result)) - (else result)))))) +(define (parse-bracket chars) + "Parse CHARS, a list of characters that extracted from a '[...]' sequence." + (match chars + ((start #\- end) + `(range ,start ,end)) + (lst + `(set ,@lst)))) -(define (compile-glob-pattern str) - "Return an sexp that represents the compiled form of STR, a glob pattern -such as \"foo*\" or \"foo??bar\"." +(define (string->sglob str) + "Return an sexp, called an \"sglob\", that represents the compiled form of +STR, a glob pattern such as \"foo*\" or \"foo??bar\"." (define flatten (match-lambda (((? string? str)) str) (x x))) - (let loop ((index 0) - (indices (wildcard-indices str)) + (define (cons-string chars lst) + (match chars + (() lst) + (_ (cons (list->string (reverse chars)) lst)))) + + (let loop ((chars (string->list str)) + (pending '()) + (brackets 0) (result '())) - (match indices + (match chars (() - (flatten (cond ((zero? index) - (list str)) - ((= index (string-length str)) - (reverse result)) - (else - (reverse (cons (string-drop str index) - result)))))) - ((wildcard-index . rest) - (let ((wildcard (match (string-ref str wildcard-index) + (flatten (reverse (if (null? pending) + result + (cons-string pending result))))) + (((and chr (or #\? #\*)) . rest) + (let ((wildcard (match chr (#\? '?) (#\* '*)))) - (match (substring str index wildcard-index) - ("" (loop (+ 1 wildcard-index) - rest - (cons wildcard result))) - (str (loop (+ 1 wildcard-index) - rest - (cons* wildcard str result))))))))) + (if (zero? brackets) + (loop rest '() 0 + (cons* wildcard (cons-string pending result))) + (loop rest (cons chr pending) brackets result)))) + ((#\[ . rest) + (if (zero? brackets) + (loop rest '() (+ 1 brackets) + (cons-string pending result)) + (loop rest (cons #\[ pending) (+ 1 brackets) result))) + ((#\] . rest) + (cond ((zero? brackets) + (error "unexpected closing bracket" str)) + ((= 1 brackets) + (loop rest '() 0 + (cons (parse-bracket (reverse pending)) result))) + (else + (loop rest (cons #\] pending) (- brackets 1) result)))) + ((chr . rest) + (loop rest (cons chr pending) brackets result))))) + +(define (compile-sglob sglob) + "Compile SGLOB into a more efficient representation." + (if (string? sglob) + sglob + (let loop ((sglob sglob) + (result '())) + (match sglob + (() + (reverse result)) + (('? . rest) + (loop rest (cons char-set:full result))) + ((('range start end) . rest) + (loop rest (cons (ucs-range->char-set + (char->integer start) + (+ 1 (char->integer end))) + result))) + ((('set . chars) . rest) + (loop rest (cons (list->char-set chars) result))) + ((head . rest) + (loop rest (cons head result))))))) + +(define string->compiled-sglob + (compose compile-sglob string->sglob)) (define (glob-match? pattern str) "Return true if STR matches PATTERN, a compiled glob pattern as returned by -'compile-glob-pattern'." +'compile-sglob'." (let loop ((pattern pattern) (str str)) (match pattern - ((? string? literal) (string=? literal str)) - (((? string? one)) (string=? one str)) - (('*) #t) - (('?) (= 1 (string-length str))) - (() #t) + ((? string? literal) + (string=? literal str)) + (() + (string-null? str)) + (('*) + #t) (('* suffix . rest) (match (string-contains str suffix) (#f #f) (index (loop rest (string-drop str (+ index (string-length suffix))))))) - (('? . rest) + (((? char-set? cs) . rest) (and (>= (string-length str) 1) - (loop rest (string-drop str 1)))) + (let ((chr (string-ref str 0))) + (and (char-set-contains? cs chr) + (loop rest (string-drop str 1)))))) ((prefix . rest) (and (string-prefix? prefix str) (loop rest (string-drop str (string-length prefix)))))))) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 45a419217c..43e9eb60c9 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> -;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -67,15 +67,15 @@ NAMES (strings)." (string-append package-name-prefix (string-downcase name))))) (define* (elpa-url #:optional (repo 'gnu)) - "Retrun the URL of REPO." + "Retrieve the URL of REPO." (let ((elpa-archives - '((gnu . "http://elpa.gnu.org/packages") - (melpa-stable . "http://stable.melpa.org/packages") - (melpa . "http://melpa.org/packages")))) + '((gnu . "https://elpa.gnu.org/packages") + (melpa-stable . "https://stable.melpa.org/packages") + (melpa . "https://melpa.org/packages")))) (assq-ref elpa-archives repo))) (define* (elpa-fetch-archive #:optional (repo 'gnu)) - "Retrive the archive with the list of packages available from REPO." + "Retrieve the archive with the list of packages available from REPO." (let ((url (and=> (elpa-url repo) (cut string-append <> "/archive-contents")))) (if url @@ -190,7 +190,7 @@ include VERSION." url))) (_ #f)))) -(define* (elpa-package->sexp pkg) +(define* (elpa-package->sexp pkg #:optional license) "Return the `package' S-expression for the Emacs package PKG, a record of type '<elpa-package>'." @@ -234,12 +234,17 @@ type '<elpa-package>'." (home-page ,(elpa-package-home-page pkg)) (synopsis ,(elpa-package-synopsis pkg)) (description ,(elpa-package-description pkg)) - (license license:gpl3+)))) + (license ,license)))) (define* (elpa->guix-package name #:optional (repo 'gnu)) "Fetch the package NAME from REPO and produce a Guix package S-expression." - (let ((pkg (fetch-elpa-package name repo))) - (and=> pkg elpa-package->sexp))) + (match (fetch-elpa-package name repo) + (#f #f) + (package + ;; ELPA is known to contain only GPLv3+ code. Other repos may contain + ;; code under other license but there's no license metadata. + (let ((license (and (eq? 'gnu repo) 'license:gpl3+))) + (elpa-package->sexp package license))))) ;;; |